perm filename PASCAL.OBK[PAS,SYS]1 blob
sn#329943 filedate 1978-09-07 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00059 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00006 00002 (*$T-,S1300,R16*)
C00012 00003 (********************************************************************************
C00014 00004 (********************************************************************************
C00017 00005 (*******************************************************************************
C00021 00006 (*******************************************************************************
C00023 00007 PROGRAM PASCAL
C00031 00008 TYPE
C00047 00009 VAR
C00063 00010 INITPROCEDURE (* MNEMONICS *)
C00117 00011 PROCEDURE INIT←COMPILE
C00121 00012 PROCEDURE ERROR(FERRNR: INTEGER)
C00123 00013 PROCEDURE ENTERID(FCP: CTP)
C00125 00014 PROCEDURE GET←DIRECTIVES
C00154 00015 PROCEDURE COMPILE
C00161 00016 PROCEDURE INSYMBOL
C00176 00017 PROCEDURE SEARCHSECTION(FCP: CTP VAR FCP1: CTP)
C00181 00018 PROCEDURE BLOCK(FPROCP: CTP FSYS,LEAVEBLOCKSYS: SETOFSYS)
C00185 00019 FUNCTION COMPTYPES(FSP1,FSP2: STP) : BOOLEAN
C00192 00020 PROCEDURE SIMPLETYPE(FSYS: SETOFSYS VAR FSP: STP VAR FSIZE: ADDRRANGE
C00198 00021 PROCEDURE FIELDLIST(FSYS: SETOFSYS VAR FRECVAR: STP VAR FFIRSTFIELD: CTP)
C00208 00022 BEGIN
C00219 00023 PROCEDURE LABELDECLARATION
C00228 00024 PROCEDURE PROCEDUREDECLARATION(PROCFLAG: BOOLEAN)
C00246 00025 PROCEDURE BODY(FSYS: SETOFSYS)
C00258 00026 PROCEDURE ENTERBODY
C00274 00027 PROCEDURE GENERATE←CODE(FINSTR: INSTRANGE FAC: ACRANGE VAR FATTR: ATTR)
C00281 00028 PROCEDURE LOAD(VAR FATTR: ATTR)
C00286 00029 PROCEDURE WRITE←MACHINE←CODE(WRITE←FLAG:WRITE←FORM)
C00296 00030 PROCEDURE CODE←FOR←FILEBLOCKS
C00309 00031 PROCEDURE CODE←FOR←DEBUG
C00323 00032 PROCEDURE CODE←FOR←CONTROL
C00329 00033 PROCEDURE CODE←FOR←SYMBOLS
C00335 00034 BEGIN
C00337 00035 PROCEDURE STATEMENT(FSYS,STATENDS: SETOFSYS)
C00350 00036 PROCEDURE CALL(FSYS: SETOFSYS FCP: CTP)
C00355 00037 PROCEDURE VARIABLE(FSYS: SETOFSYS)
C00360 00038 PROCEDURE CALL←SUPPORT
C00372 00039 PROCEDURE MESSAGE
C00383 00040 PROCEDURE NEWDISPOSE
C00392 00041 PROCEDURE FIRSTLAST
C00399 00042 PROCEDURE GETLINENR
C00407 00043 PROCEDURE CALL
C00427 00044 BEGIN
C00431 00045 PROCEDURE EXPRESSION
C00435 00046 PROCEDURE SIMPLEEXPRESSION(FSYS: SETOFSYS)
C00452 00047 BEGIN
C00463 00048 PROCEDURE ASSIGNMENT(FCP: CTP)
C00474 00049 PROCEDURE GOTOSTATEMENT
C00477 00050 PROCEDURE CASESTATEMENT
C00485 00051 PROCEDURE REPEATSTATEMENT
C00494 00052 PROCEDURE WITHSTATEMENT
C00497 00053 BEGIN
C00501 00054 BEGIN
C00504 00055 BEGIN
C00507 00056 BEGIN (* COMPILE *)
C00520 00057 PROCEDURE ENTERSTDTYPES
C00534 00058 PROCEDURE ENTERUNDECL
C00536 00059 BEGIN (*PASCAL*)
C00539 ENDMK
C⊗;
(*$T-,S1300,R16*)
(********************************************************************************
*
* DECSYSTEM-10 PASCAL COMPILER
* ****************************
*
* (C) COPYRIGHT H.-H. NAGEL
* INSTITUT FUER INFORMATIK
* DER UNIVERSITAET HAMBURG
* SCHLUETERSTRASSE 70
* 2000 HAMBURG-13
* GERMANY
* 1976
*
* MAR-73 SYNTAX ANALYSIS INCLUDING ERROR HANDLING,
* CHECKS BASED ON DECLARATIONS AND ADDRESS-
* AND CODE-GENERATION FOR A HYPOTHETICAL
* STACK COMPUTER BY URS AMMAN
*
* FACHGRUPPE COMPUTER-WISSENSCHAFTEN
* EIDG. TECHNISCHE HOCHSCHULE
* CH-8006 ZUERICH
*
* DEC-73 CODE-GENERATION FOR DECSYSTEM-10
* BY C.O. GROSSE-LINDEMANN, F.W. LORENZ,
* H.H. NAGEL AND P.J. STIRL /1/
*
* JUL-74 IMPLEMENTATION OF NEW FEATURES BY STUDENTS
* DURING A PRACTICAL PROGRAMMING COURSE /2/
*
* DEC-74 MODIFICATIONS TO GENERATE RELOCATABLE
* LINK-10 OBJECT-CODE BY E. KISICKI
*
* DEC-74 DEBUG SYSTEM /5/
* BY P. PUTFARKEN
*
* APR-76 POST-MORTEM DUMP FACILITY /6/
* BY B. NEBEL AND B. PRETSCHNER
*
* AUG-76 IMPROVEMENTS AND ADAPTATION TO STANDARD-PASCAL
* AND CDC 6000-3.4. PASCAL AS PRESENTED IN
* "PASCAL - USER MANUAL AND REPORT" /3,4,7/
* BY E.KISICKI
*
* NOV-76 FORMAL PROCEDURE/FUNCTION PARAMETERS
* AND CORRECTION OF ERRORS
* BY H. LINDE
*
* INSTITUT FUER INFORMATIK
* SCHLUETERSTRASSE 70
* D-2000 HAMBURG 13
*
* /1/ F.W. LORENZ, P.J. STIRL
* UEBERTRAGUNG EINES PASCAL-COMPILERS AUF DAS DECSYSTEM-10
* DIPLOMARBEIT, IFI, HH, 74
*
* C.O. GROSSE-LINDEMANN, H.H. NAGEL
* POSTLUDE TO A PASCAL-COMPILER BOOTSTRAP
* BERICHT NR. 11, IFI, HH, 74
*
* C.O. GROSSE-LINDEMANN
* WEITERFUEHRENDE ARBEITEN AM PASCAL-COMPILER ZUR
* STEIGERUNG DER BENUTZERFREUNDLICHKEIT
* DIPLOMARBEIT, IFI, HH, 75
*
* /2/ ERWEITERUNG VON SPRACHDEFINITION, COMPILER UND LAUFZEIT-
* UNTERSTUETZUNG BEI PASCAL/ ERGEBNISSE EINES PRAKTIKUMS
* IM INFORMATIK GRUNDSTUDIUM
* STUD. BEITRAEGE BEARBEITET VON H.H. NAGEL
* MITTEILUNGEN NR. 16, IFI, HH, 75
*
* /3/ H.H. NAGEL
* PASCAL FOR DECSYSTEM-10/ EXPERIENCES AND FURTHER PLANS
* MITTEILUNGEN NR. 21, IFI, HH, NOV-75
*
* /4/ KATHLEEN JENSEN, NIKLAUS WIRTH
* PASCAL USER MANUAL AND REPORT
* LECTURE NOTES IN COMPUTER SCIENCE VOL 18
* SPRINGER-VERLAG BERLIN-HEIDELBERG-NEW YORK
*
* /5/ P. PUTFARKEN
* TESTHILFEN FUER PASCAL PROGRAMME
* DIPLOMARBEIT, IFI, HH, 76
*
* /6/ B. NEBEL, B. PRETSCHNER
* ERWEITERUNG DES DECSYSTEM-10 PASCAL COMPILERS UM
* EINE MOEGLICHKEIT ZUR ERZEUGUNG EINES POST-MORTEM DUMP
* MITTEILUNGEN NR. 34 , IFI, HH, JUN-76
*
* /7/ E. KISICKI, H.H. NAGEL
* PASCAL FOR THE DECSYSTEM-10
* MITTEILUNGEN NR. , IFI, HH, NOV-76
*
********************************************************************************)
(********************************************************************************
*
* HINTS TO INTERPRET ABBREVIATIONS
*
* BRACK : BRACKET "[ ]" IX : INDEX
* C : CURRENT L : LOCAL
* C : COUNTER L : LEFT
* CST : CONSTANT PARENT : "( )"
* CTP : IDENTIFIER POINTER P/PTR : POINTER
* EL : ELEMENT P/PROC : PROCEDURE
* F : FORMAL R : RIGHT
* F : FIRST S : STRING
* F : FILE SY : SYMBOL
* F/FUNC : FUNCTION V : VARIABLE
* G : GLOBAL V : VALUE
* ID : IDENTIFIER BP : BYTEPOINTER
* REL : RELATIVE REL : RELOCATION
*
********************************************************************************)
(********************************************************************************
*
* FILES NECESSARY TO IMPLEMENT THE PASCAL COMPILER
*
* SOURCE-CODE
*
* PASCAL.PAS : PASCAL
*
* LIBPAS.PAS : CCL (OPTION, GETOPTION, GETFILENAME, GETPARAMETER)
* DDT (DEBUG)
* STATUS (GETSTATUS)
* READ (READIRANGE, READCRANGE, READRRANGE, READSCALAR,
* READISET, READCSET, READDSET)
* WRITE (WRTSCALAR, WRTISET, WRTDSET,WRTCSET)
* UNDEFINED (UNDEFINED)
*
* LIBMAC.MAC : MACRO RUNTIME SUPPORT
*
* CROSS.PAS : CROSS REFERENCE WITHOUT CODE-GENERATION
*
*
* OBJECT-CODE
*
* PASLIB.REL : SEARCH LIBRARY CONTAINING LIBPAS.REL
* AND LIBMAC.REL
*
*
* EXECUTABLE-CODE
*
* PASCAL.LOW : PASCAL LOW-SEGMENT
* PASCAL.SHR : PASCAL SHARED HIGH-SEGMENT
* CROSS.LOW : CROSS LOW-SEGMENT
* CROSS.SHR : CROSS SHARED HIGH-SEGMENT
*
*
* INFORMATION AND MAINTENANCE
*
* PASCAL.DOC : A GUIDE FOR THE DECSYSTEM-10 PASCAL DIALECT
*
*******************************************************************************)
(*******************************************************************************
*
* HOW TO GENERATE A NEW PASCAL COMPILER
*
* 1) CHANGES TO THE RUNTIME-SUPPORT
*
* LET LIBPAS.PAS AND LIBMAC.MAC BE YOUR MODIFIED RUNTIME SUPPORT
*
* .COMPILE LIBMAC.MAC/LIST
* ...
* .COMPILE LIBPAS.PAS(EXTERN/NOCHECK)/LIST
* PASCAL: LIBPAS [CCL: OPTION, ... ]
* ...
* PASCAL: LIBPAS [DEBUG: DEBUG]
* ...
* EXIT
* .RENAME PASLIB.OLD=PASLIB.REL
* .R FUDGE2
* *PASLIB=LIBPAS,LIBMAC/A$
* *PASLIB=PASLIB/X$
* *↑C
*
*
* 2) CHANGES TO THE COMPILER
*
* LET PASCAL.PAS BE YOUR NEW COMPILER SOURCE
* (DO NOT FORGET TO CHANGE THE "HEADER" AND CHECK FOR THE CORRECT
* FILE DESCRIPTIONS FOR PASLIB AND CROSS IN INITPROCEDURE
* "SEARCH LIBRARIES")
*
* .EXECUTE P1=PASCAL(NOCHECK/CODESIZE:1300/RUNCORE:16)
* PASCAL: P1 [PASCAL]
* 0 ERROR(S) DETECTED
* ...
* LINK: LOADING
* [...P1 EXECUTION]
* OBJECT= P2.REL/CODESIZE:1300/RUNCORE:16/NOCHECK/EXECUTE/CREF
* LIST= <CR>
* SOURCE= PASCAL.PAS
* PASCAL: P2 [PASCAL]
* 0 ERROR(S) DETECTED
* ...
* CROSS: P2
* NO ERROR IN BLOCKSTRUCTURE
* LINK: LOADING
* [...P2 EXECUTION]
* OBJECT= P3.REL/CODESIZE:1300/RUNCORE:16/NOCHECK
* LIST= <CR>
* SOURCE= PASCAL.PAS
* PASCAL: P3 [PASCAL]
* 0 ERROR(S) DETECTED
* ...
* EXIT
* .R FILCOM
* *TTY:=P2.REL,P3.REL
* NO DIFFERENCES ENCOUNTERED
* *↑C
* .DELETE P1.*,P3.*
* .RENAME PASCAL.*=P2.*
* .RENAME PASCAL.OLD=PASCAL.PAS
* .RENAME PASCAL.PAS=PASCAL.NEW
* .PRINT PASCAL.CRL
* .LOAD PASCAL/MAP
* .SSAVE PASCAL
*
*
* 3) CHANGES TO CROSS
*
* .LOAD CROSS(NOCHECK)/LIST/COMPILE
* ...
* EXIT
* .SSAVE CROSS
*
********************************************************************************)
(*******************************************************************************
*
* KNOWN BUGS AND RESTRICTIONS
*
* 1) IF THE DEVICE-PARAMETER FOR RESET/REWRITE IS NOT
* DEFAULTED, NEW BUFFERS ARE ALLOCATED WITHOUT REGARD
* TO THE FACT THAT THE NEW DEVICE COULD BE THE SAME AS THE
* THE OLD DEVICE.
*
* 2) COMPARISON OF VARIABLES OF TYPE PACKED RECORD OR
* PACKED ARRAY MAY CAUSE TROUBLE IF THESE VARIABLES APPEAR
* IN A VARIANT PART OR WERE ASSIGNED FROM A VARIANT PART
*
* 3) TOO LARGE ARRAY DIMENSIONS (F.E. MININT..MAXINT) CAUSE
* ARITHMETIC OVERFLOW INSTEAD OF AN APPROPRIATE ERROR
* MESSAGE
*
* 4) ARRAYS OF FILE AND RECORDS WITH FILES AS COMPONENTS
* ARE NOT IMPLEMENTED
*
* 5) SEGMENTED FILES ARE NOT IMPLEMENTED
*
* 6) CALL OF EXTERNAL COBOL OR ALGOL PROCEDURES IS
* NOT IMPLEMENTED
*
*
********************************************************************************)
PROGRAM PASCAL;
LABEL
0;
CONST
(* NIL = 377777B; *)
(* ALFALENGTH = 10; *)
(* MININT = 400000000000B; *)
(* MAXINT = 377777777777B; *)
(* MAXREAL = 1.7014118432E+38; *)
(* SMALLREAL= 1.4693680107E-39; *)
HEADER = 'PASCAL VERSION FROM 30-DEC-76';
(*COMPILER PARAMETERS:*)
(**********************)
DISPLIMIT = 20; (* MAXIMUM DECLARATION-SCOPE NESTING *)
MAX←FILE = 12; (* MAXIMUM NUMBER OF USER-DECLARED FILES *)
MAX←CHANNEL = 15; (* HIGHEST DATA-CHANNEL ASSIGNED TO A FILE *)
MAXLEVEL = 10; (* MAXIMUM PROC/FUNC LEVEL *)
STRGLGTH = 120; (* MAXIMUM LENGTH FOR STRING-CONSTANT *)
SIZEOFFILEBLOCK = 21; (* SIZE OF FILE CONTROL-BLOCK *)
CIXMAX = 1000; (* STANDARD SIZE OF CODE-ARRAY *)
MAXERR = 4; (* MAXIMUM OF ERRORS IN 1 SOURCE-LINE *)
LABMAX = 9999; (* MAXIMUM VALUE OF A PROGRAM LABEL *)
BITMAX = 36; (* NR. OF BITS OF 1 DECSYSTEM-10 MACHINE-WORD *)
HWCSTMAX = 377777B; (* MAXIMUM POS. INTEGER IN HALFWORD *)
ENTRYMAX = 20; (* MAXIMUM ENTRIES INTO EXTERN PROGRAM *)
EXTPFMAX = 20; (* MAXIMUM OF EXTERN STANDARD PROC/FUNC *)
STDMAX = 36; (* NR. OF STANDARD NAMES *)
RSWMAX = 42; (* NR. OF RESERVED WORDS *)
RSWMAXP1 = 43; (* RESERVED WORDS PLUS 1 *)
STDCHCNTMAX = 132; (* MAXIMUM OF CHARS IN SOURCE-LINE *)
BASEMAX = 71; (* MAXIMUM VALUE OF A SET ELEMENT *)
OFFSET = 40B; (* USED FOR SETS OF CHARACTERS *)
BUFFER←SIZE = 200B; (* DECSYSTEM-10 DISK-BUFFER SIZE *)
TAGFMAX = 5; (* MAX. NR. OF VARIANTS ALLOWED IN CALL OF "NEW" *)
JUMP←MAX = 50; (* MAX. NR. OF LABEL DECLARATIONS *)
REG0 = 0; (* WORKREGISTER *)
REG1 = 1; (* WORKREGISTER (USED FOR ARRAY-BYTEPOINTERS) *)
REGIN = 1; (* TO INITIALIZE REGC *)
STDPARREGCMAX = 6; (* HIGHEST REGISTER USED FOR PARAMETERS *)
WITHIN = 12; (* FIRST REGISTER FOR WITH-STACK *)
NEWREG = 13; (* LAST PLACE OF NEW-STACK *)
BASIS = 14; (* ADDR OF CURRENT ACTIVATION-REC, STATIC AND DYNAMIC LINK *)
TOPP = 15; (* FIRST FREE WORD IN DATA-STACK *)
JBREL = 44B; (* LOCATION OF (0,HIGHEST LEGAL LOW-SEG ADDRESS) *)
JBSA = 120B; (* LOCATION OF (1ST UNUSED LOW-SEG ADDRESS,START-ADDRESS OF PROGRAM) *)
JBFF = 121B; (* LOCATION OF (0,POINTER BEHIND LAST FILE-BUFFER) *)
JBAPR = 125B; (* LOCATION OF (0,PC AFTER PROGRAM ERROR) *)
JBDDT = 74B; (* LOCATION OF (LAST PASDDT-ADDR, PASDDT-ADDR + 2) *)
TTY←SIXBIT = 646471B; (* SIXBIT REPR. FOR 'TTY ' *)
DSK←SIXBIT = 446353B; (* SIXBIT REPR. FOR 'DSK ' *)
ASCII←MODE = 0; (* (SYSTEM-) FLAGS FOR ASCII-MODE *)
BINARY←MODE = 14B; (* (SYSTEM-) FLAGS FOR BINARY-MODE *)
TEXT←FILE = 0; (* (PASCAL-) FLAGS FOR "PACKED FILE OF (SUBRANGE OF) CHAR" = "TEXT" *)
DATA←FILE = 1; (* (PASCAL-) FLAGS FOR OTHER FILES *)
DEBUG←SAVE = 0B; (* ADDR OF DEBUG-SYSTEM STACK *)
DEBUG←STOP = 1B; (* PUSHJ INTO DEBUG ON "STOP" *)
DEBUG←PAGEHEAD = 2B; (* START OF "STOP"-CHAIN *)
DEBUG←STACKBOTTOM = 3B; (* 1ST WORD OF PROGRAM-STACK *)
DEBUG←INITIALIZATION = 6B; (* PUSHJ INTO DEBUG-INITIALIZATION *)
DEBUG←PROGRAMNAME = 7B; (* ADDR OF ADDR OF PROGRAMNAME *)
SYSTEM←LOW←START = 140B; (* LOC 0B..137B CONTAIN SYSTEM-INFO. *)
SYSTEM←HIGH←START = 400010B; (* LOC 400000B..400007B CONTAIN SYSTEM-INFO. *)
LOW←START = 10B; (* LOC 0B..7B RESERVED FOR DEBUG-PROGR. *)
HIGH←START = 400000B; (* START OF EXECUTABLE CODE *)
MAXADDR = 777777B; (* HIGHEST LEGAL ADDRESS *)
ITEM←1 = 1; (* LINK ITEM 1: CODE *)
ITEM←2 = 2; (* LINK ITEM 2: SYMBOLS *)
ITEM←3 = 3; (* LINK ITEM 3: HIGHSEG *)
ITEM←4 = 4; (* LINK ITEM 4: ENTRIES *)
ITEM←5 = 5; (* LINK ITEM 5: LOW-/ HIGHSEGMENT BREAK *)
ITEM←6 = 6; (* LINK ITEM 6: PROGRAM NAME *)
ITEM←7 = 7; (* LINK ITEM 7: START ADDRESS *)
ITEM←10 = 10B; (* LINK ITEM 10: INTERNAL REQUESTS *)
ITEM←17 = 17B; (* LINK ITEM 17: LINK LIBRARIES *)
ENTRY←SYMBOL = 0; (* ENTRY SYMBOL FLAG *)
GLOBAL←SYMBOL = 1; (* GLOBAL SYMBOL FLAG *)
LOCAL←SYMBOL = 2; (* LOCAL SYMBOL FLAG *)
SIXBIT←SYMBOL = 6; (* SIXBIT SYMBOL FLAG *)
EXTERN←SYMBOL = 14B; (* EXTERN SYMBOL FLAG *)
TYPE
(* INTEGER = MININT..MAXINT *)
(* REAL = -MAXREAL..MAXREAL *)
(* CHAR = ' '..'←' *)
(* ASCII = NUL..DEL *)
(* BOOLEAN = (FALSE,TRUE) *)
(* TEXT = PACKED FILE OF CHAR *)
(* ALFA = PACKED ARRAY[1..ALFALENGTH] OF CHAR *)
(*DESCRIBING:*)
(*************)
(*BASIC SYMBOLS*)
(***************)
SYMBOL = (IDENT,INTCONST,REALCONST,STRINGCONST,NOTSY,MULOP,ADDOP,RELOP,
LPARENT,RPARENT,LBRACK,RBRACK,COMMA,SEMICOLON,PERIOD,ARROW,
COLON,BECOMES,LABELSY,CONSTSY,TYPESY,VARSY,FUNCTIONSY,
PROCEDURESY,PACKEDSY,SETSY,ARRAYSY,RECORDSY,FILESY,FORWARDSY,
BEGINSY,IFSY,CASESY,REPEATSY,WHILESY,FORSY,WITHSY,LOOPSY,
GOTOSY,EXITSY,ENDSY,ELSESY,UNTILSY,OFSY,DOSY,TOSY,DOWNTOSY,
EXTERNSY,PASCALSY,FORTRANSY,PROGRAMSY,
THENSY,OTHERSY,INITPROCSY,SEGMENTSY,OTHERSSY);
OPERATOR = (NOOP,MUL,RDIV,ANDOP,IDIV,IMOD,PLUS,MINUS,OROP,
LTOP,LEOP,GEOP,GTOP,NEOP,EQOP,INOP);
SETOFSYS = SET OF SYMBOL;
(*BASIC RANGE DEFINITIONS*)
(*************************)
LEVRANGE = 0..MAXLEVEL;
KEYRANGE = 0..77B;
FILEFORMRANGE = 0..77B;
FILEMODERANGE = 0..77B;
ADDRRANGE = 0..MAXADDR;
INSTRANGE = 0..677B;
RADIXRANGE = 0..37777777777B;
FLAGRANGE = 0..17B;
BITRANGE = 0..BITMAX;
ACRANGE = 0..15;
IBRANGE = 0..1;
CODERANGE = 0..HWCSTMAX;
BITS5 = 0..37B;
BITS6 = 0..77B;
BITS7 = 0..177B;
BITS12 = 0..7777B;
BITS18 = 0..777777B;
SETRANGE = 0..BASEMAX;
JUMP←RANGE = 1..JUMP←MAX;
(*CONSTANTS*)
(***********)
BPOINTER = PACKED RECORD
SBITS,PBITS: BITRANGE;
IBIT,DUMMYBIT: IBRANGE;
IREG: ACRANGE;
RELADDR: ADDRRANGE
END;
CSTCLASS = (INT,REEL,PSET,STRD,STRG,BPTR);
CSP = ↑ CONSTNT;
CONSTNT = RECORD
SELFCSP: CSP; NOCODE: BOOLEAN;
CASE CCLASS: CSTCLASS OF
INT : (INTVAL: INTEGER;
INTVAL1:INTEGER (*TO ACCESS SECOND WORD OF PVAL*) );
REEL: (RVAL: REAL);
PSET: (PVAL: SET OF SETRANGE);
STRD,
STRG: (SLGTH: 0..STRGLGTH;
SVAL: PACKED ARRAY [1..STRGLGTH] OF CHAR);
BPTR: (BYTE: BPOINTER)
END;
VALU = RECORD
CASE INTEGER OF
1: (IVAL: INTEGER);
2: (VALP: CSP);
3: (BYTE: BPOINTER)
END;
(*DATA STRUCTURES*)
(*****************)
STRUCTFORM = (SCALAR,SUBRANGE,POINTER,POWER,ARRAYS,RECORDS,FILES,TAGFWITHID,TAGFWITHOUTID,VARIANT);
DECLKIND = (STANDARD,DECLARED);
STP = ↑STRUCTURE;
CTP = ↑IDENTIFIER;
STRUCTURE = PACKED RECORD
SELFSTP: STP; SIZE: ADDRRANGE;
NOCODE: BOOLEAN; BITSIZE: BITRANGE;
CASE FORM: STRUCTFORM OF
SCALAR: (CASE SCALKIND: DECLKIND OF
DECLARED: (DB0: BITS6; FCONST: CTP;
VECTORADDR, VECTORCHAIN: ADDRRANGE;
DIMENSION: INTEGER; NEXTSCALAR: STP;
REQUEST: BOOLEAN; TLEV: LEVRANGE));
SUBRANGE: (DB1: BITS7; RANGETYPE: STP; VMIN, VMAX: VALU);
POINTER: (DB2: BITS7; ELTYPE: STP);
POWER: (DB3: BITS7; ELSET: STP);
ARRAYS: (ARRAYPF: BOOLEAN; DB4: BITS6; ARRAYBPADDR: ADDRRANGE;
AELTYPE, INXTYPE: STP);
RECORDS: (RECORDPF: BOOLEAN; DB5: BITS6;
FSTFLD: CTP; RECVAR: STP);
FILES: (DB6: BITS6; FILEPF: BOOLEAN; FILTYPE: STP;
FILE←FORM: FILEFORMRANGE; FILE←MODE: FILEMODERANGE);
TAGFWITHID,
TAGFWITHOUTID: (DB7: BITS7; FSTVAR: STP;
CASE BOOLEAN OF
TRUE : (TAGFIELDP: CTP);
FALSE: (TAGFIELDTYPE: STP));
VARIANT: (DB9: BITS7; NXTVAR, SUBVAR: STP; FIRSTFIELD: CTP; VARVAL: VALU)
END;
BTP = ↑BYTEPOINT;
BYTEPOINT = PACKED RECORD
LAST: BTP;
ARRAYSP: STP;
BITSIZE: BITRANGE
END;
GTP = ↑GLOBPTR;
GLOBPTR = RECORD
NEXTGLOBPTR: GTP ;
FIRSTGLOB,
LASTGLOB : ADDRRANGE ;
FCIX : CODERANGE
END ;
FTP = ↑FILBLCK;
FILBLCK = PACKED RECORD
NEXTFTP : FTP ;
FILEIDENT : CTP
END ;
PTP = ↑PROGRAMPARAMETER;
PROGRAMPARAMETER = PACKED RECORD
NEXTPTP: PTP;
FILEIDPTR: CTP;
FILEID: ALFA;
INPUTFILE: BOOLEAN
END;
(*NAMES*)
(*******)
SCALARFORM = (INTEGERFORM,CHARFORM,REALFORM,BOOLFORM,DECLAREDFORM);
IDCLASS = (TYPES,KONST,VARS,FIELD,PROC,FUNC,LABELS);
SETOFIDS = SET OF IDCLASS;
IDKIND = (ACTUAL,FORMAL);
PACKKIND = (NOTPACK,PACKK,HWORDR,HWORDL);
IDENTIFIER = PACKED RECORD
NAME: ALFA;
LLINK, RLINK: CTP;
IDTYPE: STP; NEXT: CTP;
SELFCTP: CTP; NOCODE: BOOLEAN;
CASE KLASS: IDCLASS OF
KONST: (VALUES: VALU);
VARS: (VKIND: IDKIND;
VLEV: LEVRANGE;
CHANNEL: ACRANGE;
VDUMMY1: BITS5;
VDUMMY2: BITS18;
VADDR: ADDRRANGE);
FIELD: (CASE PACKF: PACKKIND OF
NOTPACK,
HWORDL,
HWORDR: (HDUMMY: BITS12; FLDADDR: ADDRRANGE);
PACKK: (PDUMMY: BITS12; FLDBYTE: BPOINTER));
PROC,
FUNC: (CASE PFDECKIND: DECLKIND OF
STANDARD: (KEY: KEYRANGE);
DECLARED: (PFLEV: LEVRANGE;
PARLISTSIZE,PFADDR: ADDRRANGE;
HIGHEST←REGISTER: ACRANGE;
CASE PFKIND: IDKIND OF
ACTUAL: (FORWDECL: BOOLEAN;
EXTERNDECL: BOOLEAN;
ACTIVATED: BOOLEAN;
PFCHAIN:CTP;
LANGUAGE: SYMBOL;
TESTFWDPTR: CTP;
EXTERNALNAME: ALFA;
LINKCHAIN: PACKED ARRAY[LEVRANGE] OF ADDRRANGE);
FORMAL: (FPARAM:CTP)));
LABELS:(SCOPE: LEVRANGE;
JUMP←INDEX: 0..JUMP←MAX;
EXIT←JUMP: BOOLEAN;
GOTO←CHAIN: ADDRRANGE;
LABEL←ADDRESS: ADDRRANGE)
END;
DISPRANGE = 0..DISPLIMIT;
WHERE = (BLCK (* ID IS VARIABLE ID*)
,CREC (* ID IS FIELD ID OF RECORD WITH CONSTANT ADDRESS*)
,VREC (* ID IS FIELD ID OF RECORD WITH VARIABLE ADDRESS*)
);
(*RELOCATION*)
(************)
CODEREFS = (NOREF,CONSTREF,EXTERNREF,FORWARDREF,GOTOREF,POINTREF,NOINSTR,SAVEREF,DEBUGREF);
RELBYTE = (NO,RIGHT,LEFT,BOTH);
RELWORD = PACKED ARRAY[0..17] OF RELBYTE;
SUPPORTS = ( STACKOVERFLOW, ERRORINASSIGNMENT, INDEXERROR, OVERFLOW, INPUTERROR,
ERRORINSET, NOCOREAVAILABLE,
ALLOCATE, FREE,
EXITPROGRAM, RUNPROGRAM, READPGMPARAMETER,
RESETFILE, REWRITEFILE, OPENTTY, FORTRANRESET, FORTRANEXIT, CLOSEFILE,
GETCHARACTER, GETFILE, GETLINE, PUTFILE, PUTLINE, PUTPAGE, PUTBUFFER,
INITIALIZEDEBUG, ENTERDEBUG, LOADDEBUG,
CONVERTINTEGERTOREAL,
ASCIITIME, ASCIIDATE,
READREAL, READINTEGER, READCHARACTER, READSTRING, READPACKEDSTRING,
WRITECHARACTER, WRITEDEFCHARACTER,
WRITESTRING, WRITEDEFSTRING,
WRITEPACKEDSTRING, WRITEDEFPACKEDSTRING,
WRITEBOOLEAN, WRITEDEFBOOLEAN,
WRITEREAL, WRITEDEF1REAL, WRITEDEF2REAL,
WRITEINTEGER, WRITEDEFINTEGER,
WRITEHEXADECIMAL, WRITEDEFHEXADECIMAL,
WRITEOCTAL, WRITEDEFOCTAL,
READIRANGE, READCRANGE, READRRANGE,
READSCALAR,
READISET, READCSET, READDSET,
WRTSCALAR,
WRTISET, WRTCSET, WRTDSET);
(*EXPRESSIONS*)
(*************)
ATTRKIND = (CST,VARBL,EXPR);
ATTR = RECORD
TYPTR: STP;
CASE KIND: ATTRKIND OF
CST: (CVAL: VALU);
VARBL: (PACKFG: PACKKIND;
INDEXR: ACRANGE;
INDBIT: IBRANGE;
VLEVEL: LEVRANGE;
BPADDR,DPLMT: ADDRRANGE;
VRELBYTE: RELBYTE;
SUBKIND: STP;
VCLASS: IDCLASS;
VBYTE: BPOINTER);
EXPR: (REG:ACRANGE)
END;
TESTP = ↑ TESTPOINTER;
TESTPOINTER = PACKED RECORD
ELT1,ELT2: STP;
LASTTESTP: TESTP
END;
(*OTHER TYPES:*)
(**************)
WRITE←FORM = (WRITE←ENTRY,WRITE←NAME,WRITE←HISEG,WRITE←GLOBALS,WRITE←CODE,WRITE←INTERNALS,WRITE←LIBRARY,
WRITE←DEBUG,WRITE←FILEBLOCKS,WRITE←SYMBOLS,WRITE←START,WRITE←END);
NAMEKIND = (STDCONST,STDFILE,STDPROC,STDFUNC,DECLPROC,DECLFUNC);
BTPKIND = (UNUSED,REQUESTED,CALCULATED,USED);
ETP = ↑ ERRORWITHTEXT;
ERRORWITHTEXT = PACKED RECORD
NUMBER: INTEGER;
NEXT: ETP;
STRING: ALFA
END;
KSP = ↑ KONSTREC;
KONSTREC = PACKED RECORD
ADDR, KADDR: ADDRRANGE;
CONSTPTR: CSP;
NEXTKONST: KSP;
DOUBLE←CHAIN: BOOLEAN
END;
PDP10INSTR = PACKED RECORD
INSTR : INSTRANGE ;
AC : ACRANGE;
INDBIT : IBRANGE;
INXREG : ACRANGE;
ADDRESS : ADDRRANGE
END ;
CHANGE←FORM=(INTCST,PDP10CODE,REALCST,STRCST,SIXBITCST,HALFWD,PDP10BP,RADIX) ;
CHARWORD = PACKED ARRAY[1..5] OF CHAR;
HALFS = PACKED RECORD
LEFTHALF: ADDRRANGE;
RIGHTHALF: ADDRRANGE
END;
CODEPOINTER = ↑CODEARRAY;
CODEARRAY = RECORD
CASE CHANGE←FORM OF
PDP10CODE: (INSTRUCTION: ARRAY[CODERANGE] OF PDP10INSTR);
INTCST: (WORD: ARRAY[CODERANGE] OF INTEGER);
HALFWD: (HALFWORD: ARRAY[CODERANGE] OF HALFS)
END;
RELPOINTER = ↑RELARRAY;
RELARRAY = PACKED ARRAY[CODERANGE] OF RELBYTE;
REFPOINTER = ↑REFARRAY;
REFARRAY = PACKED ARRAY[CODERANGE] OF CODEREFS;
BUFFERPOINTER = ↑COMMANDBUFFER;
COMMANDBUFFER = PACKED ARRAY[0..BUFFER←SIZE] OF ASCII;
PAGEELEM = PACKED RECORD
WORD1: PDP10INSTR;
LHALF: ADDRRANGE; RHALF: ADDRRANGE
END;
DEBENTRY = RECORD
LASTPAGEELEM: PAGEELEM;
GLOBALIDTREE: ADDRRANGE;
STANDARDIDTREE: ADDRRANGE;
INTPOINT: STP;
REALPOINT: STP;
BOOLPOINT: STP;
CHARPOINT: STP
END;
NLK = ↑NEWLINKS;
NEWLINKS = PACKED RECORD
REFTYPE : STP;
REFADR : ADDRRANGE;
NEXT : NLK;
END;
(*------------------------------------------------------------------------------*)
VAR
(*VALUES RETURNED BY SOURCE PROGRAM SCANNER INSYMBOL:*)
(*****************************************************)
SY: SYMBOL; (*LAST SYMBOL*)
OP: OPERATOR; (*CLASSIFICATION OF LAST SYMBOL*)
VAL: VALU; (*VALUE OF LAST CONSTANT*)
LGTH: INTEGER; (*LENGTH OF LAST STRING CONSTANT*)
ID: ALFA; (*LAST IDENTIFIER (POSSIBLY TRUNCATED)
OR LAST INTEGER CONST (FOR LABEL PROCESSING)*)
CH: CHAR; (*LAST CHARACTER*)
(*COUNTERS:*)
(***********)
I: INTEGER;
ENTRIES: INTEGER;
SUPPORT←INDEX: SUPPORTS;
LANGUAGE←INDEX: SYMBOL;
CHCNTMAX: 0..STDCHCNTMAX;
CHCNT: 0..STDCHCNTMAX; (*CHARACTER COUNTER*)
CODEEND, (*FIRST LOCATION NOT USED FOR INSTRUCTIONS*)
LCMAIN,
LC,IC: ADDRRANGE; (*DATA LOCATION AND INSTRUCTION COUNTER*)
PROGRAM←COUNT: INTEGER;
(*SWITCHES:*)
(***********)
DP, (*DECLARATION PART*)
RESET←POSSIBLE, (*TO IGNORE SWITCHES WHICH MUST NOT BE RESET*)
SEARCH←ERROR, (*TO ALLOW FORWARD REFERENCES IN POINTER TYPE
DECLARATION BY SUPPRESSING ERROR MESSAGE*)
EXTERNAL, (*IF TRUE, ALL LEVEL-1 PROC/FUNC MAY BE
DECLARED AS "EXTERN" BY OTHER PROGRAMS*)
TTYREAD, (*TO INHIBIT TTYOPEN ('*'-PROMPTING) IF NO TTY-INPUT REQUESTED*)
DEBUG, (*ENABLE DEBUGGING*)
DEBUG←SWITCH, (*TO GENERATE DEBUG INFORMATION*)
LIST←CODE, (*LIST MACRO CODE*)
LPTFILE, (*TO INHIBIT GENERATION OF LIST-FILE*)
INITGLOBALS, (*INITIALIZE GLOBAL VARIABLES*)
LOADNOPTR, (*IF TRUE, NO POINTERVARIABLE SHALL BE LOADED*)
FORTRAN←ENVIROMENT,
LOAD←AND←GO,
CROSS←REFERENCE,
FIRST←SYMBOL,
RUNTIME←CHECK: BOOLEAN; (*IF TRUE, PERFORM RUNTIME-TESTS*)
(*POINTERS:*)
(***********)
SEXTERNPFPTR,
LOCALPFPTR, EXTERNPFPTR: CTP; (*PTRS TO LOCAL/EXTERNAL PROC/FUNC-CHAIN*)
PARMPTR: PTP; (*PTR TO PROGRAMPARM.-CHAIN*)
STDFILEPTR: ARRAY[1..4] OF CTP; (*PTRS TO STD-FILES*)
ALFAPTR,PACKC9PTR,
PACKC5PTR,ASCIIPTR,
PACKC6PTR,PACKC8PTR,
INTPTR,REALPTR,CHARPTR,
BOOLPTR,NILPTR,TEXTPTR: STP; (*POINTERS TO ENTRIES OF STANDARD IDS*)
SDECLSCALPTR,
DECLSCALPTR: STP; (*PTR TO CHAIN OF DECLARED SCALARS*)
UTYPPTR,UCSTPTR,UVARPTR,
UFLDPTR,UPRCPTR,UFCTPTR, (*POINTERS TO ENTRIES FOR UNDECLARED IDS*)
FORWARD←POINTER←TYPE: CTP; (*HEAD OF CHAIN OF FORW DECL TYPE IDS*)
ERRMPTR, ERRMPTR1: ETP; (*TO CHAIN ERRORS WITH TEXT*)
LAST←LABEL: CTP; (*TOP OF LABEL CHAIN*)
SLASTBTP,
LASTBTP: BTP; (*HEAD OF BYTEPOINTERTABLE*)
SFILEPTR,
FILEPTR: FTP;
FIRSTKONST: KSP;
ANYFILEPTR: STP; (*TO ALLOW FILES OF "ANY" TYPE AS
VAR PARAMETERS IN STAND. PROC/FUNC*)
FGLOBPTR,CGLOBPTR : GTP ; (*POINTER TO FIRST AND CURRENT GLOBAL INITIALISATION RECORD*)
GLOBTESTP : TESTP ; (*POINTER TO LAST PAIR OF POINTERTYPES*)
GLOBNEWLINK : NLK ; (*POINTER TO NEW-LINKS*)
(*BOOKKEEPING OF DECLARATION LEVELS:*)
(************************************)
LEVEL: LEVRANGE; (*CURRENT STATIC LEVEL*)
DISX, (*LEVEL OF LAST ID SEARCHED BY SEARCHID*)
TOP: DISPRANGE; (*TOP OF DISPLAY*)
DISPLAY: ARRAY[DISPRANGE] OF
PACKED RECORD
FNAME: CTP;
CASE OCCUR: WHERE OF
CREC: (CLEV: LEVRANGE;
CINDR: ACRANGE;
CINDB: IBRANGE;
CRELBYTE: RELBYTE;
CDSPL,
CLC : ADDRRANGE)
END;
(*ERROR MESSAGES:*)
(*****************)
ERROR←FLAG: BOOLEAN; (*TRUE IF SYNTACTIC ERRORS DETECTED*)
ERROR←IN←HEADING: BOOLEAN;
ERRINX: 0..MAXERR ; (*NR OF ERRORS IN CURRENT SOURCE LINE*)
ERRORCOUNT: INTEGER; (*TOTAL NR OF ERRORS DETECTED IN PROGRAM*)
ERROR←EXIT: BOOLEAN; (*TO ENABLE EXIT DURING COMPILATION*)
OVERRUN: BOOLEAN;
ERRLIST:
ARRAY [1..MAXERR] OF
PACKED RECORD
ARW: 1..MAXERR;
POS: 1..STDCHCNTMAX;
NMR: 1..600;
TIC: CHAR
END;
ERRMESS15 : ARRAY [1..24] OF PACKED ARRAY [1..15] OF CHAR;
ERRMESS20 : ARRAY [1..15] OF PACKED ARRAY [1..20] OF CHAR;
ERRMESS25 : ARRAY [1..18] OF PACKED ARRAY [1..25] OF CHAR;
ERRMESS30 : ARRAY [1..20] OF PACKED ARRAY [1..30] OF CHAR;
ERRMESS35 : ARRAY [1..17] OF PACKED ARRAY [1..35] OF CHAR;
ERRMESS40 : ARRAY [1..11] OF PACKED ARRAY [1..40] OF CHAR;
ERRMESS45 : ARRAY [1..18] OF PACKED ARRAY [1..45] OF CHAR;
ERRMESS50 : ARRAY [1..10] OF PACKED ARRAY [1..50] OF CHAR;
ERRMESS55 : ARRAY [1.. 6] OF PACKED ARRAY [1..55] OF CHAR;
ERRORINLINE,
FOLLOWERROR : BOOLEAN;
ERRLINE,
BUFFER: ARRAY [1..STDCHCNTMAX] OF CHAR;
PAGECNT,
LINECNT: INTEGER;
LINENR: PACKED ARRAY [1..5] OF CHAR;
(*EXPRESSION COMPILATION:*)
(*************************)
GATTR: ATTR; (*DESCRIBES THE EXPR CURRENTLY COMPILED*)
AOS: (B0,B1,B2,B3,AOSINSTR,SOSINSTR); (*TESTS CONDITION FOR AOS/SOS-INSTRUCTION*)
LEFTSIDE: ATTR; (*LEFT SIDE OF ASSIGNMENT*)
(*COMPILATION OF PACKED STRUCTURES:*)
(***********************************)
ARRAYBPS: ARRAY[1:18] OF
RECORD
ABYTE: BPOINTER; BYTEMAX: BITRANGE;
ADDRESS: ADDRRANGE;
STATE: BTPKIND
END;
(*DEBUG-SYSTEM:*)
(***************)
LASTSTOP: ADDRRANGE; (*LAST BREAKPOINT*)
LASTLINE, (*LINENUMBER FOR BREAKPOINTS*)
LINEDIFF, (*DIFFERENCE BETWEEN ↑ AND LINECNT*)
LASTPAGE:INTEGER; (*LAST PAGE THAT CONTAINS A STOP*)
PAGEHEADADR, (*OVERGIVE TO DEBUG.PAS*)
LASTPAGER: ADDRRANGE; (*POINTS AT LAST PAGERECORD*)
PAGER: PAGEELEM; (*ACTUAL PAGERECORD*)
DEBENTRY←SIZE: INTEGER; (*DEBENTRY LENGTH *)
DEBUGENTRY: DEBENTRY;
IDRECSIZE: ARRAY[IDCLASS] OF INTEGER;
STRECSIZE: ARRAY[STRUCTFORM] OF INTEGER;
(*STRUCTURED CONSTANTS:*)
(***********************)
LETTERSORDIGITS,LETTERS,DIGITS,LETTERSDIGITSORLEFTARROW,HEXADIGITS: SET OF CHAR;
CONSTBEGSYS,SIMPTYPEBEGSYS,TYPEBEGSYS,BLOCKBEGSYS,SELECTSYS,FACBEGSYS,
LANGUAGESYS,STATBEGSYS,TYPEDELS: SETOFSYS;
RW: ARRAY [1..RSWMAX] OF ALFA;
FRW: ARRAY [1..11(*ALFALENGTH+1*)] OF 1..RSWMAXP1;
RSY: ARRAY [1..RSWMAX] OF SYMBOL;
SSY: ARRAY [' '..'←'] OF SYMBOL;
ROP: ARRAY [1..RSWMAX] OF OPERATOR;
SOP: ARRAY [' '..'←'] OF OPERATOR;
NA: ARRAY[NAMEKIND] OF ARRAY[1..STDMAX] OF ALFA;
NAMAX: ARRAY[NAMEKIND] OF INTEGER;
EXTNA: ARRAY[DECLPROC..DECLFUNC] OF ARRAY[1..EXTPFMAX] OF ALFA;
EXTLANGUAGE: ARRAY[DECLPROC..DECLFUNC] OF ARRAY[1..EXTPFMAX] OF SYMBOL;
MNEMONICS : ARRAY[1..45] OF PACKED ARRAY[1..60] OF CHAR ;
SHOWIBIT : ARRAY[IBRANGE] OF CHAR;
SHOWRELO : ARRAY[BOOLEAN] OF CHAR;
SHOWREF : ARRAY[CODEREFS] OF CHAR;
WRITE←SUPPORT, READ←SUPPORT: ARRAY[SCALARFORM,SCALAR..POWER] OF SUPPORTS;
(*LABEL PROCESSING:*)
(*******************)
JUMPER: 0..JUMP←MAX;
JUMP←TABLE: PACKED ARRAY[JUMP←RANGE] OF ADDRRANGE;
JUMP←ADDRESS: ADDRRANGE;
(*OTHER VARIABLES:*)
(********************)
RELOCATION←BLOCK: PACKED RECORD
CASE INTEGER OF
1: (COMPONENT: ARRAY[1..20] OF INTEGER);
2: (ITEM: ADDRRANGE; COUNT: ADDRRANGE;
RELOCATOR: RELWORD;
CODE: ARRAY[0..17] OF INTEGER)
END;
RUNTIME←SUPPORT: RECORD
NAME: ARRAY[SUPPORTS] OF ALFA;
LINK: PACKED ARRAY[SUPPORTS] OF ADDRRANGE
END;
CODE←ARRAY: CODEPOINTER;
CODE←REFERENCE: REFPOINTER;
COMMAND←BUFFER: BUFFERPOINTER;
CODE←RELOCATION: RELPOINTER;
CHANGE : PACKED RECORD
CASE CHANGE←FORM OF
INTCST :(WKONST: INTEGER);
PDP10CODE:(WINSTR: PDP10INSTR);
REALCST :(WREAL: REAL);
STRCST :(WSTRING: CHARWORD);
SIXBITCST:(WSIXBIT: PACKED ARRAY[1..6] OF 0..77B);
HALFWD :(WLEFTHALF: ADDRRANGE ; WRIGHTHALF : ADDRRANGE);
PDP10BP :(WBYTE: BPOINTER);
RADIX :(FLAG: FLAGRANGE; SYMBOL: RADIXRANGE)
END;
REGC, (*TOP OF REGISTERSTACK*)
REGCMAX: ACRANGE; (*MAXIMUM OF REGISTERS FOR EXPRESSION STACK*)
CIX, (*CODE-ARRAY INDEX*)
STACKSIZE1, STACKSIZE2, (*TO INSERT LCMAX IN PROCEDURE/FUNCTION ENTRY CODE*)
PFSTART: INTEGER; (*START OF NORMAL ENTRYCODE OF EACH FUNC. OR PROC.*)
LCMAX: ADDRRANGE; LCP: CTP;
TEMPCORE, SOURCE, LIST, TTYIN : TEXT;
OBJECT: FILE OF INTEGER;
WITHIX: INTEGER; (*TOP OF WITH-REG STACK*)
HIGHEST←CODE, (*HIGH SEG. BREAK*)
MAIN←START, (*START OF BODY OF MAIN*)
IDTREE, (*POINTER TO THE IDENTIFIER-TREE*)
NAME←ADDRESS, (*ADDR OF PROGRAM-NAME(ALFA-STRING)*)
START←ADDRESS: ADDRRANGE; (*STARTADDRESS*)
LPARMPTR, BACKWPARMPTR: PTP;
DAY, TIMEOFDAY, PROGRAMNAME: ALFA;
ENTRY: ARRAY[0..ENTRYMAX] OF ALFA;
LIST←FILE, SOURCE←FILE, OBJECT←FILE: PACKED ARRAY[1..9] OF CHAR;
RTIME: ARRAY[0..3] OF INTEGER;
CORE: ARRAY[1..2] OF INTEGER;
START←CHANNEL, CODE←SIZE, RUNCORE, PARREGCMAX: INTEGER;
ENTRY←DONE: BOOLEAN;
CROSS←DEVICE: PACKED ARRAY[1..6] OF CHAR;
CROSS←PPN, CROSS←CORE: INTEGER;
LIBRARY←INDEX: INTEGER;
LIBRARY←ORDER: PACKED ARRAY[1..4] OF SYMBOL;
LIBRARY: ARRAY[PASCALSY..FORTRANSY] OF RECORD
CHAINED, CALLED: BOOLEAN;
NAME: ALFA;
PROJNR: ADDRRANGE;
PROGNR: ADDRRANGE;
DEVICE: ALFA
END;
(*------------------------------------------------------------------------------*)
INITPROCEDURE (* MNEMONICS *) ;
BEGIN
MNEMONICS[ 1] := '***001***002***003***004***005***006***007***010***011***012' ;
MNEMONICS[ 2] := '***013***014***015***016***017***020***021***022***023***024' ;
MNEMONICS[ 3] := '***025***026***027***030***031***032***033***034***035***036' ;
MNEMONICS[ 4] := '***037CALL INIT ***042***043***044***045***046CALLI OPEN ' ;
MNEMONICS[ 5] := 'TTCALL***052***053***054RENAMEIN OUT SETSTSSTATO STATUS' ;
MNEMONICS[ 6] := 'STATZ INBUF OUTBUFINPUT OUTPUTCLOSE RELEASMTAPE UGETF USETI ' ;
MNEMONICS[ 7] := 'USETO LOOKUPENTER UJEN ***101***102***103***104***105***106' ;
MNEMONICS[ 8] := '***107***110***111***112***113***114***115***116***117***120' ;
MNEMONICS[ 9] := '***121***122***123***124***125***126***127UFA DFN FSC ' ;
MNEMONICS[10] := 'IBP ILDB LDB IDPB DPB FAD FADL FADM FADB FADR ' ;
MNEMONICS[11] := 'FADRI FADRM FADRB FSB FSBL FSBM FSBB FSBR FSBRI FSBRM ' ;
MNEMONICS[12] := 'FSBRB FMP FMPL FMPM FMPB FMPR FMPRI FMPRM FMPRB FDV ' ;
MNEMONICS[13] := 'FDVL FDVM FDVB FDVR FDVRI FDVRM FDVRB MOVE MOVEI MOVEM ' ;
MNEMONICS[14] := 'MOVES MOVS MOVSI MOVSM MOVSS MOVN MOVNI MOVNM MOVNS MOVM ' ;
MNEMONICS[15] := 'MOVMI MOVMM MOVMS IMUL IMULI IMULM IMULB MUL MULI MULM ' ;
MNEMONICS[16] := 'MULB IDIV IDIVI IDIVM IDIVB DIV DIVI DIVM DIVB ASH ' ;
MNEMONICS[17] := 'ROT LSH JFFO ASHC ROTC LSHC ***247EXCH BLT AOBJP ' ;
MNEMONICS[18] := 'AOBJN JRST JFCL XCT ***257PUSHJ PUSH POP POPJ JSR ' ;
MNEMONICS[19] := 'JSP JSA JRA ADD ADDI ADDM ADDB SUB SUBI SUBM ' ;
MNEMONICS[20] := 'SUBB CAI CAIL CAIE CAILE CAIA CAIGE CAIN CAIG CAM ' ;
MNEMONICS[21] := 'CAML CAME CAMLE CAMA CAMGE CAMN CAMG JUMP JUMPL JUMPE ' ;
MNEMONICS[22] := 'JUMPLEJUMPA JUMPGEJUMPN JUMPG SKIP SKIPL SKIPE SKIPLESKIPA ' ;
MNEMONICS[23] := 'SKIPGESKIPN SKIPG AOJ AOJL AOJE AOJLE AOJA AOJGE AOJN ' ;
MNEMONICS[24] := 'AOJG AOS AOSL AOSE AOSLE AOSA AOSGE AOSN AOSG SOJ ' ;
MNEMONICS[25] := 'SOJL SOJE SOJLE SOJA SOJGE SOJN SOJG SOS SOSL SOSE ' ;
MNEMONICS[26] := 'SOSLE SOSA SOSGE SOSN SOSG SETZ SETZI SETZM SETZB AND ' ;
MNEMONICS[27] := 'ANDI ANDM ANDB ANDCA ANDCAIANDCAMANDCABSETM SETMI SETMM ' ;
MNEMONICS[28] := 'SETMB ANDCM ANDCMIANDCMMANDCMBSETA SETAI SETAM SETAB XOR ' ;
MNEMONICS[29] := 'XORI XORM XORB IOR IORI IORM IORB ANDCB ANDCBIANDCBM' ;
MNEMONICS[30] := 'ANDCBBEQV EQVI EQVM EQVB SETCA SETCAISETCAMSETCABORCA ' ;
MNEMONICS[31] := 'ORCAI ORCAM ORCAB SETCM SETCMISETCMMSETCMBORCM ORCMI ORCMM ' ;
MNEMONICS[32] := 'ORCMB ORCB ORCBI ORCBM ORCBB SETO SETOI SETOM SETOB HLL ' ;
MNEMONICS[33] := 'HLLI HLLM HLLS HRL HRLI HRLM HRLS HLLZ HLLZI HLLZM ' ;
MNEMONICS[34] := 'HLLZS HRLZ HRLZI HRLZM HRLZS HLLO HLLOI HLLOM HLLOS HRLO ' ;
MNEMONICS[35] := 'HRLOI HRLOM HRLOS HLLE HLLEI HLLEM HLLES HRLE HRLEI HRLEM ' ;
MNEMONICS[36] := 'HRLES HRR HRRI HRRM HRRS HLR HLRI HLRM HLRS HRRZ ' ;
MNEMONICS[37] := 'HRRZI HRRZM HRRZS HLRZ HLRZI HLRZM HLRZS HRRO HRROI HRROM ' ;
MNEMONICS[38] := 'HRROS HLRO HLROI HLROM HLROS HRRE HRREI HRREM HRRES HLRE ' ;
MNEMONICS[39] := 'HLREI HLREM HLRES TRN TLN TRNE TLNE TRNA TLNA TRNN ' ;
MNEMONICS[40] := 'TLNN TDN TSN TDNE TSNE TDNA TSNA TDNN TSNN TRZ ' ;
MNEMONICS[41] := 'TLZ TRZE TLZE TRZA TLZA TRZN TLZN TDZ TSZ TDZE ' ;
MNEMONICS[42] := 'TSZE TDZA TSZA TDZN TSZN TRC TLC TRCE TLZE TRCA ' ;
MNEMONICS[43] := 'TLCA TRCN TLCN TDC TSC TDCE TSCE TDCA TSCA TDCN ' ;
MNEMONICS[44] := 'TSCN TRO TLO TROE TLOE TROA TLOA TRON TLON TDO ' ;
MNEMONICS[45] := 'TSO TDOE TSOE TDOA TSOA TDON TSON ***700 ' ;
SHOWIBIT[0] := ' '; SHOWIBIT[1] := '@';
SHOWRELO[FALSE] := ' '; SHOWRELO[TRUE] := '''';
SHOWREF[NOREF] := ' '; SHOWREF[CONSTREF] := 'C';
SHOWREF[EXTERNREF] := 'E'; SHOWREF[NOINSTR] := ' ';
SHOWREF[FORWARDREF] := 'F'; SHOWREF[GOTOREF] := 'G';
SHOWREF[POINTREF] := 'P'; SHOWREF[SAVEREF] := 'S';
SHOWREF[DEBUGREF] := 'D';
END (* MNEMONICS *) ;
INITPROCEDURE (*SEARCH LIBRARIES*) ;
BEGIN
(* INSERT (???) DEVICE, PROJNR, PROGNR AND CORE FOR PASLIB AND CROSS *)
LIBRARY[PASCALSY].CHAINED := FALSE;
LIBRARY[FORTRANSY].CHAINED := FALSE;
LIBRARY[PASCALSY].CALLED := FALSE;
LIBRARY[FORTRANSY].CALLED := FALSE;
LIBRARY[PASCALSY].NAME := 'PASLIB ';
LIBRARY[FORTRANSY].NAME := 'FORLIB ';
LIBRARY[PASCALSY].DEVICE := 'DSK ';
LIBRARY[FORTRANSY].DEVICE := 'SYS ';
LIBRARY[PASCALSY].PROJNR := 0;
LIBRARY[FORTRANSY].PROJNR := 0;
LIBRARY[PASCALSY].PROGNR := 0;
LIBRARY[FORTRANSY].PROGNR := 0;
CROSS←DEVICE := 'DSK ';
CROSS←PPN := 0;
CROSS←CORE := 100; (* 50 DOESN'T WORK *)
END (*SEARCH LIBRARIES*) ;
INITPROCEDURE (*STANDARD NAMES*) ;
BEGIN
NA[STDFILE, 1] := 'INPUT '; NA[STDFILE, 2] := 'OUTPUT '; NA[STDFILE, 3] := 'TTY ';
NA[STDFILE, 4] := 'TTYOUTPUT ';
NA[STDPROC, 1] := 'GET '; NA[STDPROC, 2] := 'GETLN '; NA[STDPROC, 3] := 'PUT ';
NA[STDPROC, 4] := 'PUTLN '; NA[STDPROC, 5] := 'RESET '; NA[STDPROC, 6] := 'REWRITE ';
NA[STDPROC, 7] := 'READ '; NA[STDPROC, 8] := 'READLN '; NA[STDPROC, 9] := 'BREAK ';
NA[STDPROC,10] := 'WRITE '; NA[STDPROC,11] := 'WRITELN '; NA[STDPROC,12] := 'PACK ';
NA[STDPROC,13] := 'UNPACK '; NA[STDPROC,14] := 'NEW '; NA[STDPROC,15] := '$$$1 ';
NA[STDPROC,16] := '$$$2 '; NA[STDPROC,17] := 'GETLINENR '; NA[STDPROC,18] := '$$$3 ';
NA[STDPROC,19] := 'PAGE '; NA[STDPROC,20] := 'PROTECTION'; NA[STDPROC,21] := 'CALL ';
NA[STDPROC,22] := 'DATE '; NA[STDPROC,23] := 'TIME '; NA[STDPROC,24] := 'DISPOSE ';
NA[STDPROC,25] := 'HALT '; NA[STDPROC,26] := 'GETSEG '; NA[STDPROC,27] := 'PUTSEG ';
NA[STDPROC,28] := 'MESSAGE '; NA[STDPROC,29] := 'LINELIMIT ';
NA[STDFUNC, 1] := 'REALTIME '; NA[STDFUNC, 2] := 'ABS '; NA[STDFUNC, 3] := 'SQR ';
NA[STDFUNC, 4] := '$$$4 '; NA[STDFUNC, 5] := 'ODD '; NA[STDFUNC, 6] := 'ORD ';
NA[STDFUNC, 7] := 'CHR '; NA[STDFUNC, 8] := 'PRED '; NA[STDFUNC, 9] := 'SUCC ';
NA[STDFUNC,10] := 'EOF '; NA[STDFUNC,11] := 'EOLN '; NA[STDFUNC,12] := 'CLOCK ';
NA[STDFUNC,13] := 'CARD '; NA[STDFUNC,14] := '$$$5 '; NA[STDFUNC,15] := 'LOWERBOUND';
NA[STDFUNC,16] := 'UPPERBOUND'; NA[STDFUNC,17] := 'EOS '; NA[STDFUNC,18] := '$$$6 ';
NA[STDFUNC,19] := 'MIN '; NA[STDFUNC,20] := 'MAX '; NA[STDFUNC,21] := 'FIRST ';
NA[STDFUNC,22] := 'LAST ';
NA[DECLFUNC, 1] := 'COS '; NA[DECLFUNC, 2] := 'EXP '; NA[DECLFUNC, 3] := 'SQRT ';
NA[DECLFUNC, 4] := 'LN '; NA[DECLFUNC, 5] := 'ARCTAN '; NA[DECLFUNC, 6] := 'LOG ';
NA[DECLFUNC, 7] := 'SIND '; NA[DECLFUNC, 8] := 'COSD '; NA[DECLFUNC, 9] := 'SINH ';
NA[DECLFUNC,10] := 'COSH '; NA[DECLFUNC,11] := 'TANH '; NA[DECLFUNC,12] := 'ARCSIN ';
NA[DECLFUNC,13] := 'ARCCOS '; NA[DECLFUNC,14] := 'RANDOM '; NA[DECLFUNC,15] := 'SIN ';
NA[DECLFUNC,16] := 'ROUND '; NA[DECLFUNC,17] := 'EXPO '; NA[DECLFUNC,18] := 'OPTION ';
NA[DECLFUNC,19] := '$$$7 '; NA[DECLFUNC,20] := 'TRUNC ';
NA[STDCONST, 1] := 'FALSE '; NA[STDCONST, 2] := 'TRUE '; NA[STDCONST, 3] := 'NUL ';
NA[STDCONST, 4] := 'SOH '; NA[STDCONST, 5] := 'STX '; NA[STDCONST, 6] := 'ETX ';
NA[STDCONST, 7] := 'EOT '; NA[STDCONST, 8] := 'ENQ '; NA[STDCONST, 9] := 'ACK ';
NA[STDCONST,10] := 'BEL '; NA[STDCONST,11] := 'BS '; NA[STDCONST,12] := 'HT ';
NA[STDCONST,13] := 'LF '; NA[STDCONST,14] := 'VT '; NA[STDCONST,15] := 'FF ';
NA[STDCONST,16] := 'CR '; NA[STDCONST,17] := 'SO '; NA[STDCONST,18] := 'SI ';
NA[STDCONST,19] := 'DLE '; NA[STDCONST,20] := 'DC1 '; NA[STDCONST,21] := 'DC2 ';
NA[STDCONST,22] := 'DC3 '; NA[STDCONST,23] := 'DC4 '; NA[STDCONST,24] := 'NAK ';
NA[STDCONST,25] := 'SYN '; NA[STDCONST,26] := 'ETB '; NA[STDCONST,27] := 'CAN ';
NA[STDCONST,28] := 'EM '; NA[STDCONST,29] := 'SUB '; NA[STDCONST,30] := 'ESC ';
NA[STDCONST,31] := 'FS '; NA[STDCONST,32] := 'GS '; NA[STDCONST,33] := 'RS ';
NA[STDCONST,34] := 'US '; NA[STDCONST,35] := 'SP '; NA[STDCONST,36] := 'DEL ';
NA[DECLPROC, 1] := 'GETFILENAM'; NA[DECLPROC, 2] := 'GETOPTION '; NA[DECLPROC, 3] := 'GETSTATUS ';
NAMAX[STDFILE] := 4; NAMAX[STDPROC] := 29; NAMAX[STDFUNC] := 22;
NAMAX[DECLFUNC] := 20; NAMAX[DECLPROC] := 3; NAMAX[STDCONST] := 36;
END (*STANDARD NAMES*) ;
INITPROCEDURE (*EXTERNAL PROCEDURE/FUNCTION NAMES*);
BEGIN
EXTNA[DECLFUNC, 1] := 'COS '; EXTLANGUAGE[DECLFUNC, 1] := FORTRANSY;
EXTNA[DECLFUNC, 2] := 'EXP '; EXTLANGUAGE[DECLFUNC, 2] := FORTRANSY;
EXTNA[DECLFUNC, 3] := 'SQRT '; EXTLANGUAGE[DECLFUNC, 3] := FORTRANSY;
EXTNA[DECLFUNC, 4] := 'ALOG '; EXTLANGUAGE[DECLFUNC, 4] := FORTRANSY;
EXTNA[DECLFUNC, 5] := 'ATAN '; EXTLANGUAGE[DECLFUNC, 5] := FORTRANSY;
EXTNA[DECLFUNC, 6] := 'ALOG10 '; EXTLANGUAGE[DECLFUNC, 6] := FORTRANSY;
EXTNA[DECLFUNC, 7] := 'SIND '; EXTLANGUAGE[DECLFUNC, 7] := FORTRANSY;
EXTNA[DECLFUNC, 8] := 'COSD '; EXTLANGUAGE[DECLFUNC, 8] := FORTRANSY;
EXTNA[DECLFUNC, 9] := 'SINH '; EXTLANGUAGE[DECLFUNC, 9] := FORTRANSY;
EXTNA[DECLFUNC,10] := 'COSH '; EXTLANGUAGE[DECLFUNC,10] := FORTRANSY;
EXTNA[DECLFUNC,11] := 'TANH '; EXTLANGUAGE[DECLFUNC,11] := FORTRANSY;
EXTNA[DECLFUNC,12] := 'ASIN '; EXTLANGUAGE[DECLFUNC,12] := FORTRANSY;
EXTNA[DECLFUNC,13] := 'ACOS '; EXTLANGUAGE[DECLFUNC,13] := FORTRANSY;
EXTNA[DECLFUNC,14] := 'RAN '; EXTLANGUAGE[DECLFUNC,14] := FORTRANSY;
EXTNA[DECLFUNC,15] := 'SIN '; EXTLANGUAGE[DECLFUNC,15] := FORTRANSY;
EXTNA[DECLFUNC,16] := 'ROUND '; EXTLANGUAGE[DECLFUNC,16] := PASCALSY;
EXTNA[DECLFUNC,17] := 'EXPO '; EXTLANGUAGE[DECLFUNC,17] := PASCALSY;
EXTNA[DECLFUNC,18] := 'OPTION '; EXTLANGUAGE[DECLFUNC,18] := PASCALSY;
EXTNA[DECLFUNC,19] := 'UNDEFI '; EXTLANGUAGE[DECLFUNC,19] := PASCALSY;
EXTNA[DECLFUNC,20] := 'TRUNC '; EXTLANGUAGE[DECLFUNC,20] := PASCALSY;
EXTNA[DECLPROC, 1] := 'GETFIL '; EXTLANGUAGE[DECLPROC, 1] := PASCALSY;
EXTNA[DECLPROC, 2] := 'GETOPT '; EXTLANGUAGE[DECLPROC, 2] := PASCALSY;
EXTNA[DECLPROC, 3] := 'GETSTA '; EXTLANGUAGE[DECLPROC, 3] := PASCALSY;
END (*EXTERNAL PROCUDURE/FUNCTION NAMES*);
INITPROCEDURE (*RUNTIME-, DEBUG-SUPPORT NAMES*) ;
BEGIN
RUNTIME←SUPPORT.NAME[STACKOVERFLOW] := 'CORERR ';
RUNTIME←SUPPORT.NAME[OVERFLOW] := 'OVERF. ';
RUNTIME←SUPPORT.NAME[ALLOCATE] := 'NEW ';
RUNTIME←SUPPORT.NAME[EXITPROGRAM] := 'END ';
RUNTIME←SUPPORT.NAME[GETLINE] := 'GETLN ';
RUNTIME←SUPPORT.NAME[GETFILE] := 'GET ';
RUNTIME←SUPPORT.NAME[PUTLINE] := 'PUTLN ';
RUNTIME←SUPPORT.NAME[PUTFILE] := 'PUT ';
RUNTIME←SUPPORT.NAME[RESETFILE] := 'RESETF ';
RUNTIME←SUPPORT.NAME[REWRITEFILE] := 'REWRIT ';
RUNTIME←SUPPORT.NAME[WRITEOCTAL] := 'WRTOCT ';
RUNTIME←SUPPORT.NAME[WRITEHEXADECIMAL] := 'WRTHEX ';
RUNTIME←SUPPORT.NAME[WRITEINTEGER] := 'WRTINT ';
RUNTIME←SUPPORT.NAME[LOADDEBUG] := 'DEBUG ';
RUNTIME←SUPPORT.NAME[WRITECHARACTER] := 'WRITEC ';
RUNTIME←SUPPORT.NAME[WRITEREAL] := 'WRTREA ';
RUNTIME←SUPPORT.NAME[WRITEBOOLEAN] := 'WRTBOL ';
RUNTIME←SUPPORT.NAME[WRITESTRING] := 'WRTUST ';
RUNTIME←SUPPORT.NAME[WRITEPACKEDSTRING] := 'WRTPST ';
RUNTIME←SUPPORT.NAME[READINTEGER] := 'READI ';
RUNTIME←SUPPORT.NAME[READCHARACTER] := 'READC ';
RUNTIME←SUPPORT.NAME[READREAL] := 'READR ';
RUNTIME←SUPPORT.NAME[CONVERTINTEGERTOREAL] := 'INTREA ';
RUNTIME←SUPPORT.NAME[PUTBUFFER] := 'PUTBUF ';
RUNTIME←SUPPORT.NAME[OPENTTY] := 'TTYOPN ';
RUNTIME←SUPPORT.NAME[INITIALIZEDEBUG] := 'INDEB. ';
RUNTIME←SUPPORT.NAME[ENTERDEBUG] := 'EXDEB. ';
RUNTIME←SUPPORT.NAME[GETCHARACTER] := 'GETCH ';
RUNTIME←SUPPORT.NAME[PUTPAGE] := 'PUTPG ';
RUNTIME←SUPPORT.NAME[INDEXERROR] := 'INXERR ';
RUNTIME←SUPPORT.NAME[ERRORINASSIGNMENT] := 'SRERR ';
RUNTIME←SUPPORT.NAME[RUNPROGRAM] := 'RUNPGM ';
RUNTIME←SUPPORT.NAME[READPGMPARAMETER] := 'GETPAR ';
RUNTIME←SUPPORT.NAME[READSTRING] := 'READS ';
RUNTIME←SUPPORT.NAME[READPACKEDSTRING] := 'READPS ';
RUNTIME←SUPPORT.NAME[ASCIIDATE] := 'DATE. ';
RUNTIME←SUPPORT.NAME[ASCIITIME] := 'TIME. ';
RUNTIME←SUPPORT.NAME[FREE] := 'FREE ';
RUNTIME←SUPPORT.NAME[READIRANGE] := 'READIR ';
RUNTIME←SUPPORT.NAME[READCRANGE] := 'READCR ';
RUNTIME←SUPPORT.NAME[READRRANGE] := 'READRR ';
RUNTIME←SUPPORT.NAME[READISET] := 'READIS ';
RUNTIME←SUPPORT.NAME[READCSET] := 'READCS ';
RUNTIME←SUPPORT.NAME[READDSET] := 'READDS ';
RUNTIME←SUPPORT.NAME[READSCALAR] := 'READSC ';
RUNTIME←SUPPORT.NAME[WRTISET] := 'WRTISE ';
RUNTIME←SUPPORT.NAME[WRTCSET] := 'WRTCSE ';
RUNTIME←SUPPORT.NAME[WRTDSET] := 'WRTDSE ';
RUNTIME←SUPPORT.NAME[WRTSCALAR] := 'WRTSCA ';
RUNTIME←SUPPORT.NAME[WRITEDEFINTEGER] := 'WRTIN1 ';
RUNTIME←SUPPORT.NAME[WRITEDEFOCTAL] := 'WRTOC1 ';
RUNTIME←SUPPORT.NAME[WRITEDEFHEXADECIMAL] := 'WRTHX1 ';
RUNTIME←SUPPORT.NAME[WRITEDEFBOOLEAN] := 'WRTBO1 ';
RUNTIME←SUPPORT.NAME[WRITEDEF1REAL] := 'WRTRE1 ';
RUNTIME←SUPPORT.NAME[WRITEDEFCHARACTER] := 'WRITC1 ';
RUNTIME←SUPPORT.NAME[WRITEDEFSTRING] := 'WRTUS1 ';
RUNTIME←SUPPORT.NAME[WRITEDEFPACKEDSTRING] := 'WRTPS1 ';
RUNTIME←SUPPORT.NAME[WRITEDEF2REAL] := 'WRTRE2 ';
RUNTIME←SUPPORT.NAME[FORTRANRESET] := 'RESET. ';
RUNTIME←SUPPORT.NAME[FORTRANEXIT] := 'EXIT. ';
RUNTIME←SUPPORT.NAME[CLOSEFILE] := 'CLSFIL ';
RUNTIME←SUPPORT.NAME[INPUTERROR] := 'IPTERR ';
RUNTIME←SUPPORT.NAME[ERRORINSET] := 'SETERR ';
RUNTIME←SUPPORT.NAME[NOCOREAVAILABLE] := 'NOCORE ';
READ←SUPPORT[INTEGERFORM,SUBRANGE] := READIRANGE;
READ←SUPPORT[INTEGERFORM,POWER] := READISET;
READ←SUPPORT[INTEGERFORM,SCALAR] := READINTEGER;
READ←SUPPORT[REALFORM,SUBRANGE] := READRRANGE;
READ←SUPPORT[REALFORM,SCALAR] := READREAL;
READ←SUPPORT[CHARFORM,SUBRANGE] := READCRANGE;
READ←SUPPORT[CHARFORM,POWER] := READCSET;
READ←SUPPORT[CHARFORM,SCALAR] := READCHARACTER;
READ←SUPPORT[DECLAREDFORM,SUBRANGE] := READSCALAR;
READ←SUPPORT[DECLAREDFORM,POWER] := READDSET;
READ←SUPPORT[DECLAREDFORM,SCALAR] := READSCALAR;
WRITE←SUPPORT[INTEGERFORM,POWER] := WRTISET;
WRITE←SUPPORT[CHARFORM,POWER] := WRTCSET;
WRITE←SUPPORT[DECLAREDFORM,POWER] := WRTDSET;
WRITE←SUPPORT[DECLAREDFORM,SUBRANGE] := WRTSCALAR;
WRITE←SUPPORT[DECLAREDFORM,SCALAR] := WRTSCALAR;
END (*RUNTIME-, DEBUG-SUPPORT NAMES*) ;
INITPROCEDURE (*INITSCALARS*) ;
BEGIN
PROGRAMNAME := ' ';
SOURCE←FILE := ' '; OBJECT←FILE := ' ';
FORWARD←POINTER←TYPE := NIL; LASTBTP := NIL; FGLOBPTR := NIL ; FILEPTR := NIL ;
LOCALPFPTR := NIL; EXTERNPFPTR := NIL; GLOBTESTP := NIL; LAST←LABEL := NIL;
ERRMPTR := NIL; PARMPTR := NIL; DECLSCALPTR := NIL; BACKWPARMPTR := NIL;
SDECLSCALPTR := NIL; SEXTERNPFPTR := NIL; SFILEPTR := NIL;
SLASTBTP := NIL; GLOBNEWLINK := NIL;
LIST←CODE := FALSE; LOADNOPTR := TRUE; INITGLOBALS := FALSE ; RUNTIME←CHECK := TRUE;
FOLLOWERROR := FALSE; ERRORINLINE := FALSE; RESET←POSSIBLE := TRUE; FIRST←SYMBOL := TRUE;
DP := TRUE; SEARCH←ERROR := TRUE; ERROR←FLAG := FALSE ; EXTERNAL := FALSE; OVERRUN := FALSE;
ENTRY←DONE := FALSE; DEBUG := FALSE; DEBUG←SWITCH := FALSE; LPTFILE := FALSE;
ERROR←EXIT := FALSE; TTYREAD := FALSE; LOAD←AND←GO := TRUE; CROSS←REFERENCE := FALSE;
FORTRAN←ENVIROMENT := FALSE;
IC := HIGH←START; (*START OF HIGHSEGMENT*)
LC := LOW←START; (*START OF LOWSEGMENT AVAILABLE TO PROGRAM*)
CHCNT := 0; LINECNT := 10; PAGECNT := 1; LASTLINE := -1; LASTPAGE := 0;
AOS := B0; LIBRARY←INDEX := 0; ERRINX := 0; ERRORCOUNT := 0; ENTRIES := 0;
DEBUGENTRY.STANDARDIDTREE := 0; DEBUGENTRY.GLOBALIDTREE := 0; START←CHANNEL := 0;
PARREGCMAX := STDPARREGCMAX; CHCNTMAX := STDCHCNTMAX;
CODE←SIZE := CIXMAX; RUNCORE := 0; JUMPER := 0; JUMP←ADDRESS := 0; PROGRAM←COUNT := 0
END (*INITSCALARS*) ;
INITPROCEDURE (*INITSETS*) ;
BEGIN
DIGITS := ['0'..'9'];
LETTERS := ['A'..'Z'];
HEXADIGITS := ['0'..'9','A'..'F'];
LETTERSORDIGITS := [ '0'..'9','A'..'Z'];
LETTERSDIGITSORLEFTARROW := ['0'..'9','A'..'Z','←'];
LANGUAGESYS := [FORTRANSY,PASCALSY];
CONSTBEGSYS := [ADDOP,INTCONST,REALCONST,STRINGCONST,IDENT];
SIMPTYPEBEGSYS := [ADDOP,INTCONST,REALCONST,STRINGCONST,IDENT,LPARENT] ;
TYPEBEGSYS := [ADDOP,INTCONST,REALCONST,STRINGCONST,IDENT,LPARENT,ARROW,
PACKEDSY,ARRAYSY,RECORDSY,SETSY,FILESY] ;
TYPEDELS := [ARRAYSY,RECORDSY,SETSY,FILESY];
BLOCKBEGSYS := [LABELSY,CONSTSY,TYPESY,VARSY,INITPROCSY,PROCEDURESY,FUNCTIONSY,BEGINSY];
SELECTSYS := [ARROW,PERIOD,LBRACK];
FACBEGSYS := [INTCONST,REALCONST,STRINGCONST,IDENT,LPARENT,LBRACK,NOTSY];
STATBEGSYS := [BEGINSY,GOTOSY,IFSY,WHILESY,REPEATSY,LOOPSY,FORSY,WITHSY,CASESY]
END (*INITSETS*) ;
INITPROCEDURE (*RESERVED WORDS*) ;
BEGIN
RW[ 1] := 'IF '; RW[ 2] := 'DO '; RW[ 3] := 'OF ';
RW[ 4] := 'TO '; RW[ 5] := 'IN '; RW[ 6] := 'OR ';
RW[ 7] := 'END '; RW[ 8] := 'FOR '; RW[ 9] := 'VAR ';
RW[10] := 'DIV '; RW[11] := 'MOD '; RW[12] := 'SET ';
RW[13] := 'AND '; RW[14] := 'NOT '; RW[15] := 'THEN ';
RW[16] := 'ELSE '; RW[17] := 'WITH '; RW[18] := 'GOTO ';
RW[19] := 'LOOP '; RW[20] := 'CASE '; RW[21] := 'TYPE ';
RW[22] := 'FILE '; RW[23] := 'EXIT '; RW[24] := 'BEGIN ';
RW[25] := 'UNTIL '; RW[26] := 'WHILE '; RW[27] := 'ARRAY ';
RW[28] := 'CONST '; RW[29] := 'LABEL '; RW[30] := 'EXTERN ';
RW[31] := 'RECORD '; RW[32] := 'DOWNTO '; RW[33] := 'PACKED ';
RW[34] := 'OTHERS '; RW[35] := 'REPEAT '; RW[36] := 'FORTRAN ';
RW[37] := 'FORWARD '; RW[38] := 'PROGRAM '; RW[39] := 'FUNCTION ';
RW[40] := 'PROCEDURE '; RW[41] := 'SEGMENTED '; RW[42] := 'INITPROCED';
FRW[1] := 1; FRW[2] := 1; FRW[3] := 7; FRW[4] := 15; FRW[5] := 24;
FRW[6] := 30; FRW[7] := 36; FRW[8] := 39; FRW[9] := 40; FRW[10] := 42;
FRW[11] := 43
END (*RESERVED WORDS*) ;
INITPROCEDURE (*SYMBOLS*) ;
BEGIN
RSY[1]:=IFSY; RSY[2]:=DOSY; RSY[3]:=OFSY;
RSY[4]:=TOSY; RSY[8]:=FORSY; RSY[12]:=SETSY;
RSY[5]:=RELOP; RSY[6]:=ADDOP; RSY[7]:=ENDSY;
RSY[9]:=VARSY; RSY[10]:=MULOP; RSY[11]:=MULOP;
RSY[13]:=MULOP; RSY[14]:=NOTSY; RSY[15]:=THENSY;
RSY[16]:=ELSESY; RSY[17]:=WITHSY; RSY[18]:=GOTOSY;
RSY[19]:=LOOPSY; RSY[20]:=CASESY; RSY[21]:=TYPESY;
RSY[22]:=FILESY; RSY[23]:=EXITSY; RSY[24]:=BEGINSY;
RSY[25]:=UNTILSY; RSY[26]:=WHILESY; RSY[27]:=ARRAYSY;
RSY[28]:=CONSTSY; RSY[29]:=LABELSY; RSY[30]:=EXTERNSY;
RSY[31]:=RECORDSY; RSY[32]:=DOWNTOSY; RSY[33]:=PACKEDSY;
RSY[34]:=OTHERSSY; RSY[35]:=REPEATSY; RSY[36]:=FORTRANSY;
RSY[37]:=FORWARDSY; RSY[38]:=PROGRAMSY; RSY[39]:=FUNCTIONSY;
RSY[40]:=PROCEDURESY; RSY[41]:=SEGMENTSY; RSY[42]:=INITPROCSY;
SSY['A'] := OTHERSY; SSY['B'] := OTHERSY; SSY['C'] := OTHERSY;
SSY['D'] := OTHERSY; SSY['E'] := OTHERSY; SSY['F'] := OTHERSY;
SSY['G'] := OTHERSY; SSY['H'] := OTHERSY; SSY['I'] := OTHERSY;
SSY['J'] := OTHERSY; SSY['K'] := OTHERSY; SSY['L'] := OTHERSY;
SSY['M'] := OTHERSY; SSY['N'] := OTHERSY; SSY['O'] := OTHERSY;
SSY['P'] := OTHERSY; SSY['Q'] := OTHERSY; SSY['R'] := OTHERSY;
SSY['S'] := OTHERSY; SSY['T'] := OTHERSY; SSY['U'] := OTHERSY;
SSY['V'] := OTHERSY; SSY['W'] := OTHERSY; SSY['X'] := OTHERSY;
SSY['Y'] := OTHERSY; SSY['Z'] := OTHERSY; SSY['0'] := OTHERSY;
SSY['1'] := OTHERSY; SSY['2'] := OTHERSY; SSY['3'] := OTHERSY;
SSY['4'] := OTHERSY; SSY['5'] := OTHERSY; SSY['6'] := OTHERSY;
SSY['7'] := OTHERSY; SSY['8'] := OTHERSY; SSY['9'] := OTHERSY;
SSY['+'] := ADDOP; SSY['-'] := ADDOP; SSY['*'] := MULOP;
SSY['/'] := MULOP; SSY['('] := LPARENT; SSY[')'] := RPARENT;
SSY['$'] := OTHERSY; SSY['='] := RELOP; SSY[' '] := OTHERSY;
SSY[','] := COMMA; SSY['.'] := PERIOD; SSY[''''] := OTHERSY;
SSY['['] := LBRACK; SSY[']'] := RBRACK; SSY[':'] := COLON;
SSY['#'] := OTHERSY; SSY['%'] := OTHERSY; SSY['!'] := OTHERSY;
SSY['&'] := OTHERSY; SSY['↑'] := ARROW; SSY['\'] := OTHERSY;
SSY['<'] := RELOP; SSY['>'] := RELOP; SSY['@'] := OTHERSY;
SSY['"'] := OTHERSY; SSY['?'] := OTHERSY; SSY[';'] := SEMICOLON;
SSY['←'] := OTHERSY;
END (*SYMBOLS*) ;
INITPROCEDURE (*OPERATORS*) ;
BEGIN
ROP[ 1] := NOOP; ROP[ 2] := NOOP; ROP[ 3] := NOOP; ROP[ 4] := NOOP;
ROP[ 5] := INOP; ROP[ 6] := OROP; ROP[ 7] := NOOP; ROP[ 8] := NOOP;
ROP[ 9] := NOOP; ROP[10] := IDIV; ROP[11] := IMOD; ROP[12] := NOOP;
ROP[13] :=ANDOP; ROP[14] := NOOP; ROP[15] := NOOP; ROP[16] := NOOP;
ROP[17] := NOOP; ROP[18] := NOOP; ROP[19] := NOOP; ROP[20] := NOOP;
ROP[21] := NOOP; ROP[22] := NOOP; ROP[23] := NOOP; ROP[24] := NOOP;
ROP[25] := NOOP; ROP[26] := NOOP; ROP[27] := NOOP; ROP[28] := NOOP;
ROP[29] := NOOP; ROP[30] := NOOP; ROP[31] := NOOP; ROP[32] := NOOP;
ROP[33] := NOOP; ROP[34] := NOOP; ROP[35] := NOOP; ROP[36] := NOOP;
ROP[37] := NOOP; ROP[38] := NOOP; ROP[39] := NOOP; ROP[40] := NOOP;
ROP[41] := NOOP; ROP[42] := NOOP;
SOP['+'] := PLUS; SOP['-'] := MINUS; SOP['*'] := MUL; SOP['/'] := RDIV;
SOP['='] := EQOP; SOP['#'] := NOOP; SOP['!'] := NOOP; SOP['&'] := NOOP;
SOP['<'] := LTOP; SOP['>'] := GTOP; SOP['@'] := NOOP; SOP['"'] := NOOP;
SOP[' '] := NOOP; SOP['$'] := NOOP; SOP['%'] := NOOP; SOP['('] := NOOP;
SOP[')'] := NOOP; SOP[','] := NOOP; SOP['.'] := NOOP; SOP['0'] := NOOP;
SOP['1'] := NOOP; SOP['2'] := NOOP; SOP['3'] := NOOP; SOP['4'] := NOOP;
SOP['5'] := NOOP; SOP['6'] := NOOP; SOP['7'] := NOOP; SOP['8'] := NOOP;
SOP['9'] := NOOP; SOP[':'] := NOOP; SOP[';'] := NOOP; SOP['?'] := NOOP;
SOP['A'] := NOOP; SOP['B'] := NOOP; SOP['C'] := NOOP; SOP['D'] := NOOP;
SOP['E'] := NOOP; SOP['F'] := NOOP; SOP['G'] := NOOP; SOP['H'] := NOOP;
SOP['I'] := NOOP; SOP['J'] := NOOP; SOP['K'] := NOOP; SOP['L'] := NOOP;
SOP['M'] := NOOP; SOP['N'] := NOOP; SOP['O'] := NOOP; SOP['P'] := NOOP;
SOP['Q'] := NOOP; SOP['R'] := NOOP; SOP['S'] := NOOP; SOP['T'] := NOOP;
SOP['U'] := NOOP; SOP['V'] := NOOP; SOP['W'] := NOOP; SOP['X'] := NOOP;
SOP['Y'] := NOOP; SOP['Z'] := NOOP; SOP['['] := NOOP; SOP['\'] := NOOP;
SOP[']'] := NOOP; SOP['↑'] := NOOP; SOP['←'] := NOOP; SOP[''''] := NOOP
END (*OPERATORS*) ;
INITPROCEDURE (*RECORD SIZES*);
BEGIN
DEBENTRY←SIZE := 8;
IDRECSIZE[TYPES] := 5;
IDRECSIZE[KONST] := 6;
IDRECSIZE[VARS] := 6;
IDRECSIZE[FIELD] := 6;
IDRECSIZE[PROC] := 5;
IDRECSIZE[FUNC] := 5;
IDRECSIZE[LABELS] := 5;
STRECSIZE[SCALAR] := 2;
STRECSIZE[SUBRANGE] := 4;
STRECSIZE[POINTER] := 2;
STRECSIZE[POWER] := 2;
STRECSIZE[ARRAYS] := 3;
STRECSIZE[RECORDS] := 3;
STRECSIZE[FILES] := 2;
STRECSIZE[TAGFWITHID] := 3;
STRECSIZE[TAGFWITHOUTID] := 2;
STRECSIZE[VARIANT] := 4
END (*RECORD SIZES*);
INITPROCEDURE (*ERROR MESSAGES*) ;
BEGIN
ERRMESS15[ 1] := '":" EXPECTED ';
ERRMESS15[ 2] := '")" EXPECTED ';
ERRMESS15[ 3] := '"(" EXPECTED ';
ERRMESS15[ 4] := '"[" EXPECTED ';
ERRMESS15[ 5] := '"]" EXPECTED ';
ERRMESS15[ 6] := '";" EXPECTED ';
ERRMESS15[ 7] := '"=" EXPECTED ';
ERRMESS15[ 8] := '"," EXPECTED ';
ERRMESS15[ 9] := '":=" EXPECTED ';
ERRMESS15[10] := '"OF" EXPECTED ';
ERRMESS15[11] := '"DO" EXPECTED ';
ERRMESS15[12] := '"IF" EXPECTED ';
ERRMESS15[13] := '"END" EXPECTED ';
ERRMESS15[14] := '"THEN" EXPECTED';
ERRMESS15[15] := '"EXIT" EXPECTED';
ERRMESS15[16] := 'ILLEGAL SYMBOL ';
ERRMESS15[17] := 'NO SIGN ALLOWED';
ERRMESS15[18] := 'NUMBER EXPECTED';
ERRMESS15[19] := 'NOT IMPLEMENTED';
ERRMESS15[20] := 'ERROR IN TYPE ';
ERRMESS15[21] := 'COMPILER ERROR ';
ERRMESS15[22] := 'DEVICE EXPECTED';
ERRMESS15[23] := 'ERROR IN FACTOR';
ERRMESS15[24] := 'TOO MANY DIGITS';
ERRMESS20[ 1] := '"BEGIN" EXPECTED ';
ERRMESS20[ 2] := '"UNTIL" EXPECTED ';
ERRMESS20[ 3] := 'ERROR IN OPTIONS ';
ERRMESS20[ 4] := 'CONSTANT TOO LARGE ';
ERRMESS20[ 5] := 'DIGIT MUST FOLLOW ';
ERRMESS20[ 6] := 'EXPONENT TOO LARGE ';
ERRMESS20[ 7] := 'CONSTANT EXPECTED ';
ERRMESS20[ 8] := 'SIMPLE TYPE EXPECTED';
ERRMESS20[ 9] := 'IDENTIFIER EXPECTED ';
ERRMESS20[10] := 'REALTYPE NOT ALLOWED';
ERRMESS20[11] := 'MULTIDEFINED LABEL ';
ERRMESS20[12] := 'FILENAME EXPECTED ';
ERRMESS20[13] := 'SET TYPE EXPECTED ';
ERRMESS20[14] := 'UNDEFINED LABEL ';
ERRMESS20[15] := 'UNDECLARED LABEL ';
ERRMESS25[ 1] := '"TO"/"DOWNTO" EXPECTED ';
ERRMESS25[ 2] := '8 OR 9 IN OCTAL NUMBER ';
ERRMESS25[ 3] := 'IDENTIFIER NOT DECLARED ';
ERRMESS25[ 4] := 'FILE NOT ALLOWED HERE ';
ERRMESS25[ 5] := 'INTEGER CONSTANT EXPECTED';
ERRMESS25[ 6] := 'ERROR IN PARAMETERLIST ';
ERRMESS25[ 7] := 'ALREADY FORWARD DECLARED ';
ERRMESS25[ 8] := 'THIS FORMAT FOR REAL ONLY';
ERRMESS25[ 9] := 'VARIANTTYPE MUST BE ARRAY';
ERRMESS25[10] := 'TYPE CONFLICT OF OPERANDS';
ERRMESS25[11] := 'MULTIDEFINED CASE LABEL ';
ERRMESS25[12] := 'FOR INTEGER ONLY "O"/"H" ';
ERRMESS25[13] := 'ARRAY INDEX OUT OF BOUNDS';
ERRMESS25[14] := 'MISSING FILE DECLARATION ';
ERRMESS25[15] := 'LABEL CONSTANT TOO GREAT ';
ERRMESS25[16] := 'LABEL ALREADY DECLARED ';
ERRMESS25[17] := 'END OF PROGRAM NOT FOUND ';
ERRMESS25[18] := 'MORE THAN 72 SET ELEMENTS';
ERRMESS30[ 1] := 'STRING CONSTANT IS TOO LONG ';
ERRMESS30[ 2] := 'IDENTIFIER ALREADY DECLARED ';
ERRMESS30[ 3] := 'SUBRANGE BOUNDS MUST BE SCALAR';
ERRMESS30[ 4] := 'INCOMPATIBLE SUBRANGE TYPES ';
ERRMESS30[ 5] := 'INCOMPATIBLE WITH TAGFIELDTYPE';
ERRMESS30[ 6] := 'INDEX TYPE MAY NOT BE INTEGER ';
ERRMESS30[ 7] := 'TYPE OF VARIABLE IS NOT ARRAY ';
ERRMESS30[ 8] := 'TYPE OF VARIABLE IS NOT RECORD';
ERRMESS30[ 9] := 'NO SUCH FIELD IN THIS RECORD ';
ERRMESS30[10] := 'EXPRESSION TOO COMPLICATED ';
ERRMESS30[11] := 'ILLEGAL TYPE OF OPERAND(S) ';
ERRMESS30[12] := 'TESTS ON EQUALITY ALLOWED ONLY';
ERRMESS30[13] := 'STRICT INCLUSION NOT ALLOWED ';
ERRMESS30[14] := 'FILE COMPARISON NOT ALLOWED ';
ERRMESS30[15] := 'ILLEGAL TYPE OF EXPRESSION ';
ERRMESS30[16] := 'VALUE OF CASE LABEL TOO LARGE ';
ERRMESS30[17] := 'TOO MANY NESTED WITHSTATEMENTS';
ERRMESS30[18] := 'INVALID OR NO PROGRAM HEADING ';
ERRMESS30[19] := 'TOO MANY LABEL DECLARATIONS ';
ERRMESS30[20] := 'INCOMPATIBLE FORMALPARAMETER ';
ERRMESS35[ 1] := 'STRING CONSTANT CONTAINS "<CR><LF>"';
ERRMESS35[ 2] := 'LABEL NOT DECLARED ON THIS LEVEL ';
ERRMESS35[ 3] := 'CALL NOT ALLOWED IN EXTERN PROGRAMS';
ERRMESS35[ 4] := 'MORE THAN 12 FILES DECLARED BY USER';
ERRMESS35[ 5] := 'FILE AS VALUE PARAMETER NOT ALLOWED';
ERRMESS35[ 6] := 'TOO MUCH CODE: USE OPTION CODESIZE ';
ERRMESS35[ 7] := 'NO PACKED STRUCTURE ALLOWED HERE ';
ERRMESS35[ 8] := 'VARIANT MUST BELONG TO TAGFIELDTYPE';
ERRMESS35[ 9] := 'TYPE OF OPERAND(S) MUST BE BOOLEAN ';
ERRMESS35[10] := 'SET ELEMENT TYPES NOT COMPATIBLE ';
ERRMESS35[11] := 'ASSIGNMENT TO FILES NOT ALLOWED ';
ERRMESS35[12] := 'TOO MANY LABELS IN THIS PROCEDURE ';
ERRMESS35[13] := 'INITPROCEDURE NOT ALLOWED HERE ';
ERRMESS35[14] := 'CONTROL VARIABLE MAY NOT BE FORMAL ';
ERRMESS35[15] := 'ILLEGAL TYPE OF FOR-CONTROLVARIABLE';
ERRMESS35[16] := 'ONLY PACKED FILE OF CHAR ALLOWED ';
ERRMESS35[17] := 'CONSTANT NOT IN BOUNDS OF SUBRANGE ';
ERRMESS40[ 1] := 'IDENTIFIER IS NOT OF APPROPRIATE CLASS ';
ERRMESS40[ 2] := 'TAGFIELD TYPE MUST BE SCALAR OR SUBRANGE';
ERRMESS40[ 3] := 'INDEX TYPE MUST BE SCALAR OR SUBRANGE ';
ERRMESS40[ 4] := 'TOO MANY NESTED SCOPES OF IDENTIFIERS ';
ERRMESS40[ 5] := 'POINTER FORWARD REFERENCE UNSATISFIED ';
ERRMESS40[ 6] := 'PREVIOUS DECLARATION WAS NOT FORWARD ';
ERRMESS40[ 7] := 'TYPE OF VARIABLE MUST BE FILE OR POINTER';
ERRMESS40[ 8] := 'MISSING CORRESPONDING VARIANTDECLARATION';
ERRMESS40[ 9] := 'MORE THAN 6 VARIANTS IN CALL OF "NEW" ';
ERRMESS40[10] := 'MORE THAN FOUR ERRORS IN THIS SOURCELINE';
ERRMESS40[11] := 'NO INITIALISATION ON RECORDS OR FILES ';
ERRMESS45[ 1] := 'LOW BOUND MAY NOT BE GREATER THAN HIGH BOUND ';
ERRMESS45[ 2] := 'IDENTIFIER OR "CASE" EXPECTED IN FIELDLIST ';
ERRMESS45[ 3] := 'TOO MANY NESTED PROCEDURES AND/OR FUNCTIONS ';
ERRMESS45[ 4] := 'FILE DECLARATION IN PROCEDURES NOT ALLOWED ';
ERRMESS45[ 5] := 'MISSING RESULT TYPE IN FUNCTION DECLARATION ';
ERRMESS45[ 6] := 'ASSIGNMENT TO FORMAL FUNCTION IS NOT ALLOWED ';
ERRMESS45[ 7] := 'INDEX TYPE IS NOT COMPATIBLE WITH DECLARATION';
ERRMESS45[ 8] := 'ERROR IN TYPE OF STANDARD PROCEDURE PARAMETER';
ERRMESS45[ 9] := 'ERROR IN TYPE OF STANDARD FUNCTION PARAMETER ';
ERRMESS45[10] := 'REAL AND STRING TAGFIELDS NOT IMPLEMENTED ';
ERRMESS45[11] := 'SET ELEMENT TYPE MUST BE SCALAR OR SUBRANGE ';
ERRMESS45[12] := 'ONLY ASSIGNMENTS ALLOWED IN INITPROCEDURES ';
ERRMESS45[13] := 'NO CONSTANT OR EXPRESSION FOR VAR ARGUMENT ';
ERRMESS45[14] := 'EXTERN DECLARATION NOT ALLOWED IN PROCEDURES ';
ERRMESS45[15] := 'BODY OF FORWARD DECLARED PROCEDURE MISSING ';
ERRMESS45[16] := 'DOUBLE FILE SPECIFICATION IN PROGRAM HEADING ';
ERRMESS45[17] := 'TOO MUCH CODE FOR DEBUG: TRY MORE "CODESIZE" ';
ERRMESS45[18] := 'NO FORMAL-PROC/FUNC IN FORTRAN-SUBROUTINE ';
ERRMESS50[ 1] := 'TOO MANY FORWARD REFERENCES OF PROCEDURE ENTRIES ';
ERRMESS50[ 2] := 'ASSIGNMENT TO STANDARD FUNCTION IS NOT ALLOWED ';
ERRMESS50[ 3] := 'PARAMETER TYPE DOES NOT AGREE WITH DECLARATION ';
ERRMESS50[ 4] := 'INITIALISATION ONLY BY ASSIGNMENT OF CONSTANTS ';
ERRMESS50[ 5] := 'LABEL TYPE INCOMPATIBLE WITH SELECTING EXPRESSION ';
ERRMESS50[ 6] := 'STATEMENT MUST END WITH ";","END","ELSE"OR"UNTIL" ';
ERRMESS50[ 7] := 'NOT ALLOWED IN INITPROCEDURES (PACKED STRUCTURE?) ';
ERRMESS50[ 8] := 'GOTO INTO MAIN PROGRAM NOT ALLOWED IF "EXTERN" ';
ERRMESS50[ 9] := 'ASSIGNMENT TO FUNCTION NOT ALLOWED ON THIS LEVEL ';
ERRMESS50[10] := 'NO STD- OR FORTRAN-PROC/FUNC AS ACTUAL-PROC/FUNC ';
ERRMESS55[ 1] := 'FUNCTION RESULT TYPE MUST BE SCALAR,SUBRANGE OR POINTER';
ERRMESS55[ 2] := 'REPETITION OF RESULT TYPE NOT ALLOWED IF FORW. DECL. ';
ERRMESS55[ 3] := 'REPETITION OF PARAMETER LIST NOT ALLOWED IF FORW. DECL.';
ERRMESS55[ 4] := 'NUMBER OF PARAMETERS DOES NOT AGREE WITH DECLARATION ';
ERRMESS55[ 5] := 'RESULT TYPE OF PARAMETER-FUNC DOES NOT AGREE WITH DECL.';
ERRMESS55[ 6] := 'SELECTED EXPRESSION MUST HAVE TYPE OF CONTROL VARIABLE '
END (*ERROR MESSAGES*) ;
(*----------------------------------------------------------------------------*)
PROCEDURE INIT←COMPILE;
BEGIN
PROGRAM←COUNT := PROGRAM←COUNT + 1;
PROGRAMNAME := ' ';
FORWARD←POINTER←TYPE := NIL; LASTBTP := NIL;
FGLOBPTR := NIL; FILEPTR := SFILEPTR;
LOCALPFPTR := NIL; DECLSCALPTR := SDECLSCALPTR;
GLOBTESTP := NIL; LAST←LABEL := NIL;
ERRMPTR := NIL; PARMPTR := NIL;
BACKWPARMPTR := NIL; EXTERNPFPTR := SEXTERNPFPTR;
LASTBTP := SLASTBTP;
LOADNOPTR := TRUE; INITGLOBALS := FALSE;
FOLLOWERROR := FALSE; ERRORINLINE := FALSE;
DP := TRUE; SEARCH←ERROR := TRUE;
ERROR←FLAG := FALSE; OVERRUN := FALSE;
ERROR←EXIT := FALSE; TTYREAD := FALSE;
ENTRY←DONE := FALSE; FIRST←SYMBOL := TRUE;
RESET←POSSIBLE := TRUE;
IC := HIGH←START; LC := LOW←START;
LIBRARY←INDEX := 0; ERRINX := 0;
ERRORCOUNT := 0; ENTRIES := 0;
DEBUGENTRY.STANDARDIDTREE := 0; DEBUGENTRY.GLOBALIDTREE := 0;
JUMPER := 0; JUMP←ADDRESS := 0;
AOS := B0;
FOR I := 1 TO 18 DO ARRAYBPS[I].STATE := UNUSED;
ARRAYBPS[7].STATE := REQUESTED;
RTIME[0] := CLOCK;
FOR I := 1 TO STDCHCNTMAX DO ERRLINE[I] := ' ';
FOR SUPPORT←INDEX := FIRST(SUPPORT←INDEX) TO LAST(SUPPORT←INDEX) DO
RUNTIME←SUPPORT.LINK[SUPPORT←INDEX] := 0;
RELOCATION←BLOCK.COUNT := 0;
TOP := 1; LEVEL := 1;
WITH DISPLAY[1] DO
BEGIN
FNAME := NIL; OCCUR := BLCK
END;
WHILE EXTERNPFPTR <> NIL DO
WITH EXTERNPFPTR↑ DO
BEGIN
LINKCHAIN[0] := 0; EXTERNPFPTR := PFCHAIN
END;
EXTERNPFPTR := SEXTERNPFPTR;
WHILE DECLSCALPTR <> NIL DO
WITH DECLSCALPTR↑ DO
BEGIN
VECTORADDR := 0; VECTORCHAIN := 0;
REQUEST := FALSE; DECLSCALPTR := NEXTSCALAR
END;
DECLSCALPTR := SDECLSCALPTR;
WHILE LASTBTP <> NIL DO
WITH LASTBTP↑ DO
BEGIN
ARRAYSP↑.ARRAYBPADDR := 0; LASTBTP := LAST
END;
LASTBTP := SLASTBTP
END (* INIT←COMPILE *);
PROCEDURE ERROR(FERRNR: INTEGER);
VAR
LPOS,LARW : INTEGER;
BEGIN
ERRORCOUNT := ERRORCOUNT + 1;
IF NOT FOLLOWERROR
THEN
BEGIN
ERROR←FLAG := TRUE ;
IF ERRINX >= MAXERR
THEN
BEGIN
ERRLIST[MAXERR].NMR := 410; ERRINX := MAXERR
END
ELSE
BEGIN
ERRINX := ERRINX + 1;
WITH ERRLIST[ERRINX] DO
BEGIN
NMR := FERRNR; TIC := '↑'
END
END;
FOLLOWERROR := TRUE; ERRORINLINE := TRUE;
IF (FERRNR <> 214) AND (FERRNR <> 356) AND (FERRNR <> 405) AND
(FERRNR <> 465) AND (FERRNR <> 467) AND (FERRNR <> 264) AND
(FERRNR <> 267)
THEN
IF EOLN(SOURCE)
THEN ERRLINE [CHCNT] := '↑'
ELSE ERRLINE [CHCNT-1] := '↑'
ELSE ERRLIST[ERRINX].TIC := ' ';
IF ERRINX > 1
THEN WITH ERRLIST [ ERRINX-1] DO
BEGIN
LPOS := POS; LARW := ARW
END;
WITH ERRLIST [ERRINX] DO
BEGIN
POS := CHCNT;
IF ERRINX = 1
THEN ARW := 1
ELSE
IF LPOS = CHCNT
THEN ARW := LARW
ELSE ARW := LARW + 1
END
END
END (*ERROR*) ;
PROCEDURE ENTERID(FCP: CTP);
(*ENTER ID POINTED TO BY FCP INTO THE NAME-TABLE,
WHICH ON EACH DECLARATION LEVEL IS ORGANISED AS
AN UNBALANCED BINARY TREE*)
VAR
NEW←NAME: ALFA; LCP, LCP1: CTP; LLEFT: BOOLEAN;
BEGIN
LCP := DISPLAY[TOP].FNAME;
IF LCP = NIL
THEN DISPLAY[TOP].FNAME := FCP
ELSE
BEGIN
NEW←NAME := FCP↑.NAME;
REPEAT
LCP1 := LCP;
IF LCP↑.NAME <= NEW←NAME
THEN
BEGIN
IF LCP↑.NAME = NEW←NAME
THEN (*NAME CONFLICT*)
IF NEW←NAME[1] IN DIGITS
THEN ERROR(266) (*MULTI-DECLARED LABEL*)
ELSE ERROR(302) (*MULTI-DECLARED IDENTIFIER*) ;
LCP := LCP↑.RLINK; LLEFT := FALSE
END
ELSE
BEGIN
LCP := LCP↑.LLINK; LLEFT := TRUE
END
UNTIL LCP = NIL;
IF LLEFT
THEN LCP1↑.LLINK := FCP
ELSE LCP1↑.RLINK := FCP
END;
WITH FCP↑ DO
BEGIN
LLINK := NIL; RLINK := NIL; SELFCTP := NIL
END
END (*ENTERID*) ;
PROCEDURE GET←DIRECTIVES;
(****************************************************************************************
*
* DECSYSTEM-10 CONCISE COMMAND LANGUAGE INTERFACE
*
* DEFINITIONS:
*
* <FILE SPECIFICATION> ::= <EMPTY> OR <FILENAME> OR
* <DEVICE>:<FILENAME>.<EXTENSION>[<PROJECT>,<PROGRAMMER>]<<PROTECTION>>
* (<SWITCH>/.../<SWITCH>)
* /<SWITCH>.../<SWITCH>
*
* <PROGRAMNAME>, <DEVICE>, <FILENAME>, <EXTENSION> ::= <IDENTIFIER>
* <PROJECT>, <PROGRAMMER>, <PROTECTION> ::= <UNSIGNED OCTAL NUMBER>
* <SWITCH> ::= <IDENTIFIER> OR <IDENTIFIER>:<VALUE>
* <VALUE> ::= <UNSIGNED DECIMAL NUMBER>
*
****************************************************************************************)
TYPE
ANYFILE = FILE OF INTEGER;
PACK9 = PACKED ARRAY[1..9] OF CHAR;
PACK6 = PACKED ARRAY[1..6] OF CHAR;
PACK5 = PACKED ARRAY[1..5] OF CHAR;
QUELLE←FORM = (TEMPFILE,COMMANDFILE,TELETYPEOUTPUT,TELETYPEINPUT,TELETYPE);
DELIMITER = (BLANK,LPARENT,RPARENT,COMMA,POINT,SLASH,LESS,EQUAL,GREATER,RBRACK,LBRACK,COLON,EXCLAMATION,UNKNOWN);
SWP = ↑SWITCH←DESCRIPTOR;
SWITCH←DESCRIPTOR = PACKED RECORD
NAME: ALFA;
LEFT, RIGHT: SWP;
VALUE: INTEGER
END;
VAR
SOURCE←PROTECTION , SOURCE←UFD ,
LIST←PROTECTION , LIST←UFD,
OBJECT←PROTECTION , OBJECT←UFD : INTEGER ;
SOURCE←DEVICE , LIST←DEVICE , OBJECT←DEVICE : PACK6 ;
TMP←FILENAME, COM←FILENAME : PACK9;
QUELLE: QUELLE←FORM;
END←OF←FILENAME, DEFAULTED, ERROR : BOOLEAN;
LASTCH: CHAR;
CURRENT←SWITCH, NEW←SWITCH, SWITCH←TREE: SWP;
DELIMITER1: ARRAY[' '..'/'] OF DELIMITER;
DELIMITER2: ARRAY[':'..'>'] OF DELIMITER;
DELIMITER3: ARRAY['['..']'] OF DELIMITER;
PROCEDURE STARTVALUES ;
BEGIN
QUELLE := TEMPFILE; ERROR := FALSE; DEFAULTED := TRUE; LASTCH := ' ';
SWITCH←TREE := NIL; CURRENT←SWITCH := NIL;
DELIMITER1[' '] := BLANK; DELIMITER1['!'] := EXCLAMATION;
DELIMITER1['('] := LPARENT; DELIMITER1[')'] := RPARENT;
DELIMITER1[','] := COMMA; DELIMITER1['.'] := POINT;
DELIMITER1['/'] := SLASH;
DELIMITER2[':'] := COLON; DELIMITER2['<'] := LESS;
DELIMITER2['='] := EQUAL; DELIMITER2['>'] := GREATER;
DELIMITER3['['] := LBRACK; DELIMITER3[']'] := RBRACK;
END;
PROCEDURE ENTER(FNAME: ALFA; FVALUE: INTEGER);
PROCEDURE ENTER←SWITCH(FTREE: SWP);
BEGIN
WITH FTREE↑ DO
IF NEW←SWITCH↑.NAME <> NAME
THEN
IF NEW←SWITCH↑.NAME < NAME
THEN
IF LEFT = NIL
THEN LEFT := NEW←SWITCH
ELSE ENTER←SWITCH(LEFT)
ELSE
IF RIGHT = NIL
THEN RIGHT := NEW←SWITCH
ELSE ENTER←SWITCH(RIGHT)
END (* ENTER←SWITCH *);
BEGIN (* ENTER *)
NEW(NEW←SWITCH);
WITH NEW←SWITCH↑ DO
BEGIN
NAME := FNAME; VALUE := FVALUE;
LEFT := NIL ; RIGHT := NIL
END;
IF SWITCH←TREE = NIL
THEN SWITCH←TREE := NEW←SWITCH
ELSE ENTER←SWITCH(SWITCH←TREE)
END (* ENTER *);
(**********************************************************************
*
* FUNCTION OPTION
*
* - TEST IF <SWITCH> "SWITCHNAME" HAS BEEN
* SPECIFIED IN THE DECSYSTEM-10 COMMAND-STRING
* INTERPRETED BY PREVIOUS GETPARAMETER-/GETFILENAME-CALLS.
*
**********************************************************************)
FUNCTION OPTION(SWITCHNAME: ALFA): BOOLEAN;
FUNCTION FIND←SWITCH( FTREE: SWP): BOOLEAN;
BEGIN
IF FTREE <> NIL
THEN
WITH FTREE↑ DO
IF SWITCHNAME = NAME
THEN
BEGIN
FIND←SWITCH := TRUE; CURRENT←SWITCH := FTREE
END
ELSE
IF SWITCHNAME < NAME
THEN
FIND←SWITCH := FIND←SWITCH(LEFT)
ELSE
FIND←SWITCH := FIND←SWITCH(RIGHT)
ELSE FIND←SWITCH := FALSE
END (* FIND←SWITCH *);
BEGIN (*OPTION*)
IF SWITCH←TREE = NIL
THEN
OPTION := FALSE
ELSE
OPTION := FIND←SWITCH(SWITCH←TREE)
END (*OPTION*);
(**********************************************************************
*
* PROCEDURE GETOPTION
*
* - ASSIGN <VALUE> OF "SWITCHNAME" TO "SWITCHVALUE".
*
**********************************************************************)
PROCEDURE GETOPTION(SWITCHNAME: ALFA; VAR SWITCHVALUE: INTEGER);
BEGIN
IF OPTION(SWITCHNAME)
THEN
WITH CURRENT←SWITCH↑ DO
SWITCHVALUE := VALUE
ELSE
SWITCHVALUE := 0
END (* GETOPTION *);
FUNCTION PICTURE(FCH: CHAR): DELIMITER;
BEGIN
IF FCH IN [' ','!','(',')',',','.','/',':','<','=','>','[',']']
THEN
IF FCH <= '/'
THEN PICTURE := DELIMITER1[FCH]
ELSE
IF FCH <= '>'
THEN PICTURE := DELIMITER2[FCH]
ELSE PICTURE := DELIMITER3[FCH]
ELSE PICTURE := UNKNOWN;
END (* PICTURE *);
(**********************************************************************
*
* PROCEDURE GETFILENAME
*
* - READ DECSYSTEM-10 <FILE SPECIFICATION> FROM
* "SOURCEFILE".
*
**********************************************************************)
PROCEDURE GETFILENAME(VAR SOURCEFILE: TEXT;
VAR FILENAME: PACK9;
VAR PROTECTION,UFD: INTEGER;
VAR DEVICE: PACK6;
FILEVARIABLE: ALFA);
VAR
BUFFER: ALFA;
I, J, K, IMAX, OCVAL, SOURCE←PROT, SOURCE←PPN: INTEGER;
SOURCE←FIL: PACKED ARRAY[1..9] OF CHAR;
SOURCE←DEV: PACKED ARRAY[1..6] OF CHAR;
CH,STATUS: CHAR;
NEW←STATUS: BOOLEAN;
PROCEDURE RE←INITIALIZE;
BEGIN
I := 0; BUFFER := ' '; OCVAL := 0;
NEW←STATUS := FALSE;
END (* RE←INITIALIZE *);
PROCEDURE INITIALIZE;
BEGIN
FILENAME := ' '; DEVICE := 'DSK '; STATUS := ' '; IMAX := 6;
CH := ' '; UFD := 0; PROTECTION := 0; ERROR := FALSE; END←OF←FILENAME := FALSE;
RE←INITIALIZE; DEFAULTED := TRUE
END (* INITIALIZE *);
PROCEDURE READCHAR;
BEGIN
I := I + 1;
IF I > IMAX
THEN ERROR := TRUE
ELSE BUFFER[I] := CH
END (*READCHAR*) ;
PROCEDURE READOCTAL;
BEGIN
IF CH IN ['0'..'7']
THEN
BEGIN
OCVAL := OCVAL * 10B + ORD(CH) - ORD('0')
END
ELSE ERROR := TRUE
END (*READOCTAL*) ;
PROCEDURE READDECIMAL;
BEGIN
IF CH IN ['0'..'9']
THEN
BEGIN
OCVAL := OCVAL * 10 + ORD(CH) - ORD('0')
END
ELSE ERROR := TRUE
END (*READDECIMAL*) ;
PROCEDURE SETSTATUS;
BEGIN
IF CH <> ' '
THEN
BEGIN
CASE PICTURE(CH) OF
COLON :
ERROR := STATUS <> ' ';
POINT :
ERROR := NOT (STATUS IN [' ',':']);
LBRACK :
ERROR := NOT (STATUS IN [' ',':','.']);
LESS :
ERROR := NOT (STATUS IN [' ',':','.',']']);
COMMA :
ERROR := STATUS <> '[';
RBRACK :
ERROR := STATUS <> ',';
GREATER :
ERROR := STATUS <> '<';
SLASH :
ERROR := NOT (STATUS IN [' ',':','.',']','>',')']);
LPARENT :
ERROR := NOT (STATUS IN [' ',':','.',']','>']);
RPARENT :
ERROR := STATUS <> '(';
OTHERS :
ERROR := TRUE
END;
IF NOT ERROR
THEN
BEGIN
NEW←STATUS := TRUE; STATUS := CH
END
END
END (*SETSTATUS*) ;
PROCEDURE READSWITCH;
VAR
READ←VALUE, END←OF←SWITCH: BOOLEAN;
BEGIN
IF NOT EOLN(SOURCEFILE)
THEN
BEGIN
REPEAT
IMAX := ALFALENGTH;
RE←INITIALIZE;
READ←VALUE := FALSE;
END←OF←SWITCH := FALSE;
LOOP
IF EOLN(SOURCEFILE)
THEN
BEGIN
END←OF←SWITCH := TRUE; CH := ' '
END
ELSE READ(SOURCEFILE,CH);
LASTCH := CH
EXIT IF NOT (CH IN ['0'..'9',':','A'..'Z',' ']) OR END←OF←SWITCH;
IF CH <> ' '
THEN
IF READ←VALUE
THEN READDECIMAL
ELSE
IF CH = ':'
THEN READ←VALUE := TRUE
ELSE READCHAR
END;
IF I > 0
THEN ENTER(BUFFER,OCVAL)
UNTIL NOT (CH IN ['/','!',',']) OR ((CH = ',') AND (STATUS <> '(')) OR END←OF←SWITCH;
IF CH IN [',','=']
THEN
BEGIN
END←OF←FILENAME := TRUE; CH := ' '
END;
SETSTATUS
END
END (* READSWITCH *);
PROCEDURE OPERAND;
PROCEDURE NEXTCH;
BEGIN
IF EOLN(SOURCEFILE)
THEN
BEGIN
END←OF←FILENAME := TRUE; CH := ' '
END
ELSE READ(SOURCEFILE,CH);
LASTCH := CH;
IF END←OF←FILENAME OR ((CH=',') AND (STATUS<>'[')) OR (CH='=')
THEN
BEGIN
END←OF←FILENAME := TRUE;
CASE PICTURE(STATUS) OF
BLANK:
CH := '.';
COLON:
CH := '.';
POINT:
CH := '[';
RPARENT,
SLASH,
GREATER,
RBRACK:
BEGIN
CH := ' '; STATUS := ' '
END;
OTHERS:
BEGIN
ERROR := TRUE; CH := ' '
END
END
END
END (*NEXTCH*) ;
BEGIN
(*OPERAND*)
REPEAT
NEXTCH;
IF CH IN ['A'..'Z','0'..'9']
THEN
IF STATUS IN ['[',',','<']
THEN READOCTAL
ELSE READCHAR
ELSE SETSTATUS
UNTIL NEW←STATUS OR ERROR OR END←OF←FILENAME
END (*OPERAND*) ;
PROCEDURE ASSIGNFILENAMEOREXTENSION;
BEGIN
IF I > 0
THEN
IF (FILENAME[1] = ' ') OR ((FILENAME[7] = ' ') AND (IMAX = 3))
THEN
BEGIN
IF IMAX = 3
THEN K := 6
ELSE K := 0;
FOR J := 1 TO IMAX DO FILENAME[K+J] := BUFFER[J];
END
END;
BEGIN
(*GETFILENAME*)
INITIALIZE;
IF NOT EOF(SOURCEFILE)
THEN
IF NOT EOLN(SOURCEFILE)
THEN
REPEAT
OPERAND;
IF NOT ERROR
THEN
BEGIN
CASE PICTURE(STATUS) OF
COLON:
IF I > 0
THEN
BEGIN
DEVICE := ' ' ;
FOR J := 1 TO I DO DEVICE[J] := BUFFER[J];
END ;
POINT:
BEGIN
ASSIGNFILENAMEOREXTENSION; IMAX := 3
END;
LESS,
LBRACK:
ASSIGNFILENAMEOREXTENSION;
LPARENT,
SLASH:
BEGIN
ASSIGNFILENAMEOREXTENSION; READSWITCH
END;
COMMA :
UFD := OCVAL * 1000000B;
RBRACK :
UFD := UFD + OCVAL;
GREATER :
PROTECTION := OCVAL
END;
RE←INITIALIZE; DEFAULTED := FALSE
END
UNTIL ERROR OR END←OF←FILENAME;
DEFAULTED := FILENAME[1] = ' ';
IF NOT DEFAULTED
THEN
IF NOT ERROR AND EOLN(SOURCEFILE) AND (PRED(QUELLE) <= COMMANDFILE) AND NOT EOF(SOURCEFILE)
THEN
BEGIN
READLN(SOURCEFILE); STATUS := ' '; CH := ' '; READSWITCH
END;
END (*GETFILENAME*);
(**********************************************************************
*
* PROCEDURE GETPARAMETER
*
* - READ A DECSYSTEM-10 <FILE SPECIFICATION> FROM EITHER
*
* * A TEMPCORE-FILE NAMED <1ST 3 CHARS. OF PROGRAMNAME>.TMP,
* CREATED BY DECSYSTEM-10 COMPIL-CLASS COMMANDS OR USER, OR
*
* * A COMMAND-FILE NAMED <1ST 6 CHARS. OF PROGRAMNAME>.CMD,
* CREATED BY USER, OR
*
* * TTY
*
* ALL FILES HAVE TO BE "TEXT"-FILES.
*
* TEMPCORE-FILES CAN BE ACCESSED AND CREATED AUTOMATICALLY
* BY PASCAL PROGRAMS IF THE FILENAME IS SPECIFIED AS
* 'XXX TMP' AND DEVICE IS 'DSK ', WHERE XXX ARE
* THE 1ST 3 CHARACTERS OF THE <PROGRAMNAME>. IF THE TEMPCORE-FILE
* CANNOT BE FOUND/CREATED THE DISK-FILE 'NNNXXXTMP' IS
* SEARCHED/CREATED, WHERE NNN IS THE JOB-NUMBER.
*
* THE INPUT FORMAT IS FOR
*
* * TEMPCORE- AND COMMAND-FILES:
*
* <FILE SPECIFICATION>,...,<FILE SPECIFICATION><CR><LF>
* <SWITCH>!...<SWITCH>!<CR><LF>
*
* THE SECOND LINE (USED BY COMPIL-CLASS COMMANDS) IS OPTIONAL
*
* * TTY:
*
* <FILE SPECIFICATION><CR><LF>
*
***********************************************************************)
PROCEDURE INITIALIZE;
BEGIN
IF QUELLE <> TELETYPE
THEN
BEGIN
CASE QUELLE OF
TEMPFILE:
BEGIN
COM←FILENAME := 'PASCALCMD';
TMP←FILENAME := 'PAS TMP';
RESET(TTYIN,TMP←FILENAME,0,0,'DSK ')
END;
COMMANDFILE:
RESET(TTYIN,COM←FILENAME);
TELETYPEOUTPUT:
REWRITE(TTY,'TTYOUTPUT');
TELETYPEINPUT:
RESET(TTYIN,'TTY ',0,0,'TTY ')
END;
QUELLE := SUCC(QUELLE);
IF EOF(TTYIN) AND NOT (QUELLE IN [TELETYPEINPUT,TELETYPE])
THEN INITIALIZE;
END
END (* INITIALIZE *);
PROCEDURE GETPARAMETER(VAR FILENAME: PACK9;
VAR PROTECTION,UFD: INTEGER;
VAR DEVICE: PACK6;
FILEIDENT: ALFA);
VAR
I : 1..3 ;
FILE←EXTENSION : PACKED ARRAY [ 1..3 ] OF CHAR ;
BEGIN (*GETPARAMETER*)
LOOP
IF QUELLE IN [TELETYPE,TELETYPEINPUT]
THEN
BEGIN
WRITE(TTY,FILEIDENT,'= ');BREAK(TTY);
IF QUELLE = TELETYPEINPUT
THEN INITIALIZE
ELSE READLN(TTYIN)
END;
GETFILENAME(TTYIN,FILENAME,PROTECTION,UFD,DEVICE,FILEIDENT);
IF DEVICE = 'LPT '
THEN ENTER('LPT ',0) ;
IF (PRED(QUELLE) <= COMMANDFILE) AND (FILENAME[7] = ' ') AND NOT DEFAULTED
THEN
BEGIN
IF FILEIDENT = 'SOURCE '
THEN FILE←EXTENSION := 'PAS'
ELSE
IF FILEIDENT = 'LIST '
THEN FILE←EXTENSION := 'LST'
ELSE FILE←EXTENSION := 'REL' ;
FOR I := 1 TO 3 DO FILENAME[6+I] := FILE←EXTENSION[I] ;
END ;
EXIT IF NOT ( ERROR OR (FILEIDENT = 'SOURCE ') AND (DEVICE = 'LPT ') ) ;
IF QUELLE <> TELETYPE
THEN
BEGIN
QUELLE := TELETYPEOUTPUT; INITIALIZE
END;
WRITELN(TTY,'%? SYNTAX ERROR: REENTER') ; BREAK(TTY) ;
END (* LOOP *) ;
END (*GETPARAMETER*) ;
BEGIN (*GET←DIRECTIVES*)
STARTVALUES ; INITIALIZE ;
GETPARAMETER(OBJECT←FILE,OBJECT←PROTECTION,OBJECT←UFD,OBJECT←DEVICE,'OBJECT ');
GETPARAMETER(LIST←FILE,LIST←PROTECTION,LIST←UFD,LIST←DEVICE,'LIST ');
GETPARAMETER(SOURCE←FILE,SOURCE←PROTECTION,SOURCE←UFD,SOURCE←DEVICE,'SOURCE ');
LOOP
IF SOURCE←FILE = ' '
THEN RESET(SOURCE,'SOURCE ',0,0,'DSK ')
ELSE RESET(SOURCE,SOURCE←FILE,SOURCE←PROTECTION,SOURCE←UFD,SOURCE←DEVICE) ;
EXIT IF NOT EOF(SOURCE) ;
WRITE(TTY,'%? NO ACCESS TO ') ;
IF SOURCE←FILE = ' '
THEN WRITE(TTY,'SOURCE')
ELSE WRITE(TTY,SOURCE←FILE:6,'.',SOURCE←FILE[7],SOURCE←FILE[8],SOURCE←FILE[9]);
WRITELN(TTY,' OR NOT FOUND: REENTER') ; BREAK(TTY) ;
GETPARAMETER(SOURCE←FILE,SOURCE←PROTECTION,SOURCE←UFD,SOURCE←DEVICE,'SOURCE ') ;
END (* LOOP FOR SOURCE←FILE *) ;
REWRITE(OBJECT,OBJECT←FILE,OBJECT←PROTECTION,OBJECT←UFD,OBJECT←DEVICE) ;
CROSS←REFERENCE := OPTION('CREF ') OR OPTION('C ') ;
LIST←CODE := OPTION('CODE ');
LPTFILE := NOT OPTION('NOLIST ') AND ( OPTION('LPT ') OR
OPTION('LIST ') OR
(LIST←FILE <> ' ') OR
LIST←CODE ) ;
IF LPTFILE
THEN REWRITE(LIST,LIST←FILE,LIST←PROTECTION,LIST←UFD,LIST←DEVICE) ;
DEBUG := OPTION('DEBUG ');
DEBUG←SWITCH := DEBUG;
RUNTIME←CHECK := NOT OPTION('NOCHECK ');
FORTRAN←ENVIROMENT := OPTION('FORTIO ');
EXTERNAL := OPTION('EXTERN ');
LOAD←AND←GO := NOT(OPTION('NOEXECUTE ') OR OPTION('NOLINK ') OR EXTERNAL);;
IF OPTION('CARD ')
THEN CHCNTMAX := 72;
IF OPTION('FILE ')
THEN
BEGIN
GETOPTION('FILE ',I);
IF I IN [1..MAX←FILE]
THEN START←CHANNEL := I + NAMAX[STDFILE] - 2
END;
IF OPTION('CODESIZE ')
THEN GETOPTION('CODESIZE ',CODE←SIZE);
IF OPTION('REGISTER ')
THEN
BEGIN
GETOPTION('REGISTER ',I);
IF I IN [REGIN..WITHIN]
THEN PARREGCMAX := I
END;
IF OPTION('RUNCORE ')
THEN GETOPTION('RUNCORE ',RUNCORE);
RESET(TEMPCORE,'LNK TMP');
IF NOT EOF(TEMPCORE)
THEN
BEGIN
NEW(COMMAND←BUFFER:BUFFER←SIZE);
COMMAND←BUFFER↑[0] := ' '; I := 1;
WHILE NOT EOF(TEMPCORE) AND (I < BUFFER←SIZE) DO
BEGIN
IF EOLN(TEMPCORE)
THEN
BEGIN
READLN(TEMPCORE);
COMMAND←BUFFER↑[I] := CR;
COMMAND←BUFFER↑[I+1] := LF; I := I + 2
END
ELSE
BEGIN
READ(TEMPCORE,CH);
COMMAND←BUFFER↑[I] := CH;
IF (COMMAND←BUFFER↑[I-1] = '/') AND (CH = 'D')
THEN
BEGIN
DEBUG := TRUE; DEBUG←SWITCH := TRUE; I := I - 1
END
ELSE I := I + 1
END
END;
REWRITE(TEMPCORE,'LNK TMP');
WRITE(TEMPCORE,COMMAND←BUFFER↑:I);
DISPOSE(COMMAND←BUFFER:BUFFER←SIZE)
END
ELSE
BEGIN
IF LOAD←AND←GO
THEN
BEGIN
REWRITE(TEMPCORE,'LNK TMP');
WRITE(TEMPCORE,'DSK:',OBJECT←FILE:6,' /G ');
IF NOT OPTION('NOEXECUTE ')
THEN WRITE(TEMPCORE,'/E')
END
END;
END (*GET←DIRECTIVES*) ;
PROCEDURE COMPILE;
LABEL
111;
VAR
ESCAPE: BOOLEAN;
PROCEDURE NEWPAGER;
BEGIN
WITH PAGER, WORD1 DO
BEGIN
AC := PAGECNT DIV 16;
INXREG := PAGECNT MOD 16; ADDRESS := LASTPAGER;
LHALF := LASTLINE; RHALF := LASTSTOP;
LASTLINE := -1
END
END;
PROCEDURE WRITEBUFFER;
BEGIN
IF LIST←CODE
THEN
BEGIN
WRITELN(LIST,BUFFER:CHCNT); FOR CHCNT := 1 TO 17 DO BUFFER[CHCNT] := ' '; CHCNT := 17
END
END;
PROCEDURE GETNEXTLINE;
BEGIN
LOOP
GETLINENR(SOURCE,LINENR)
EXIT IF (LINENR <> ' ') OR EOF(SOURCE);
IF DEBUG AND (LASTLINE > -1)
THEN NEWPAGER;
PAGECNT := PAGECNT + 1;
IF LPTFILE
THEN
BEGIN
PAGE(LIST); WRITELN(LIST,'PAGE ',PAGECNT:3); WRITELN(LIST)
END;
READLN(SOURCE) (*TO OVERREAD SECOND <LF> IN PAGE MARK*)
END;
IF LIST←CODE
THEN
BEGIN
IF DP
THEN WRITE(LIST,LC:6:O,SHOWRELO[(LC >= LOW←START) AND (LEVEL <= 1)])
ELSE WRITE(LIST,IC:6:O,'''');
WRITE(LIST,' ':2)
END;
IF LPTFILE
THEN
BEGIN
IF LINENR='-----'
THEN WRITE(LIST,LINECNT:5)
ELSE WRITE(LIST,LINENR) ;
WRITE(LIST,' ':3)
END
END (*GETNEXTLINE*);
PROCEDURE ENDOFLINE;
VAR
I,K: INTEGER;
BEGIN
IF CHCNT > CHCNTMAX
THEN CHCNT := CHCNTMAX;
IF LPTFILE
THEN WRITELN(LIST,BUFFER:CHCNT);
IF ERRORINLINE
THEN (*OUTPUT ERROR MESSAGES*)
BEGIN
IF ERROR←IN←HEADING
THEN WRITELN(TTY);
ERROR←IN←HEADING := FALSE;
IF LIST←CODE
THEN K := 11
ELSE K := 2;
IF LPTFILE
THEN WRITE(LIST,' ':K,'***** '); LIST←CODE := FALSE;
IF LINENR = '-----'
THEN WRITE(TTY,LINECNT:5)
ELSE WRITE(TTY,LINENR);
WRITELN(TTY,' ':3,BUFFER:CHCNT); WRITE(TTY,'P*',PAGECNT:3,'** ');
IF LPTFILE
THEN WRITELN(LIST,ERRLINE : CHCNT); WRITELN(TTY,ERRLINE : CHCNT);
FOR K := 1 TO ERRINX DO
WITH ERRLIST[K] DO
BEGIN
IF LPTFILE
THEN WRITE(LIST,' ':15,ARW:1,'.',TIC,': '); WRITE(TTY,ARW:1,'.',TIC,': ');
IF ERRMPTR <> NIL
THEN
BEGIN
ERRMPTR1 := ERRMPTR;
REPEAT
WITH ERRMPTR1↑ DO
IF NMR = NUMBER
THEN
BEGIN
IF LPTFILE
THEN WRITE(LIST,STRING:10,' - ');WRITE(TTY,STRING:10,' - ');
NUMBER := 0; ERRMPTR1 := NIL
END
ELSE ERRMPTR1 := NEXT
UNTIL ERRMPTR1 = NIL
END;
I := NMR MOD 50;
CASE NMR DIV 50 OF
3:
BEGIN
IF LPTFILE
THEN WRITE(LIST,ERRMESS15[I]); WRITE(TTY,ERRMESS15[I])
END;
4:
BEGIN
IF LPTFILE
THEN WRITE(LIST,ERRMESS20[I]); WRITE(TTY,ERRMESS20[I])
END;
5:
BEGIN
IF LPTFILE
THEN WRITE(LIST,ERRMESS25[I]); WRITE(TTY,ERRMESS25[I])
END;
6:
BEGIN
IF LPTFILE
THEN WRITE(LIST,ERRMESS30[I]); WRITE(TTY,ERRMESS30[I])
END;
7:
BEGIN
IF LPTFILE
THEN WRITE(LIST,ERRMESS35[I]); WRITE(TTY,ERRMESS35[I])
END;
8:
BEGIN
IF LPTFILE
THEN WRITE(LIST,ERRMESS40[I]); WRITE(TTY,ERRMESS40[I])
END;
9:
BEGIN
IF LPTFILE
THEN WRITE(LIST,ERRMESS45[I]); WRITE(TTY,ERRMESS45[I])
END;
10:
BEGIN
IF LPTFILE
THEN WRITE(LIST,ERRMESS50[I]); WRITE(TTY,ERRMESS50[I])
END;
11:
BEGIN
IF LPTFILE
THEN WRITE(LIST,ERRMESS55[I]); WRITE(TTY,ERRMESS55[I])
END
END;
IF LPTFILE
THEN WRITELN(LIST); WRITELN(TTY)
END;
BREAK(TTY); ERRINX := 0; ERRORINLINE := FALSE;
FOR I := 1 TO CHCNT DO ERRLINE [I] := ' ';
ERRMPTR := NIL
END;
READLN(SOURCE);
LINECNT := LINECNT + 10; CHCNT := 0;
IF ERROR←EXIT
THEN
IF FIRST←SYMBOL
THEN GOTO 0
ELSE GOTO 111
ELSE
BEGIN
IF NOT EOF(SOURCE)
THEN GETNEXTLINE
ELSE
BEGIN
IF NOT FIRST←SYMBOL
THEN ERROR(267);
ERROR←EXIT := TRUE;
ENDOFLINE
END
END
END (*ENDOFLINE*) ;
PROCEDURE ERROR←WITH←TEXT ( FERRNR: INTEGER; FTEXT: ALFA ) ;
BEGIN
ERROR(FERRNR); NEW(ERRMPTR1);
WITH ERRMPTR1↑ DO
BEGIN
NUMBER := FERRNR; STRING := FTEXT;
NEXT := ERRMPTR
END;
ERRMPTR := ERRMPTR1
END (*ERROR WITH TEXT*) ;
PROCEDURE INSYMBOL;
(*READ NEXT BASIC SYMBOL OF SOURCE PROGRAM AND RETURN ITS
DESCRIPTION IN THE GLOBAL VARIABLES SY, OP, ID, VAL AND LGTH*)
LABEL
222;
CONST
MAXDIGITS = 12;
MAX8 = 37777777777B;
TEST8 = 40000000000B;
MAX10 = 3435973836; (* MAXINT = 2 ** 35 - 1 = 34.359.738.367 *)
MAX16 = 17777777777B;
TEST16 = 20000000000B;
MAXEXP2 = 127; (* MAXREAL = 777.777.777B * 2 ** 100 *)
LOG←OF←2 = 0.30102999806;
VAR
I, K, SCALE, EXPONENT, IVAL: INTEGER;
RVAL, R, FAC: REAL;
STRINGTOOLONG, SIGN: BOOLEAN;
DIGIT: ARRAY [1..MAXDIGITS] OF 0..9;
STRING: ARRAY [1..STRGLGTH] OF CHAR;
LVP: CSP;
PROCEDURE NEXTCH;
BEGIN
IF EOLN(SOURCE)
THEN CH := ' '
ELSE
BEGIN
CH := SOURCE↑; GET(SOURCE);
CHCNT := CHCNT + 1;
IF CHCNT <= CHCNTMAX
THEN BUFFER[CHCNT] := CH
ELSE
IF CHCNTMAX = 72
THEN NEXTCH
END
END;
PROCEDURE SKIPCOMMENT;
VAR
COMMENTEND: BOOLEAN;
PROCEDURE OPTIONS;
VAR
LCH : CHAR;
LSWITCH : BOOLEAN;
LVALUE : INTEGER;
BEGIN
REPEAT
LVALUE := 0; LSWITCH := FALSE;
NEXTCH; LCH := CH;
IF NOT (CH IN ['\','*'])
THEN NEXTCH;
IF CH IN (['+','-'] + DIGITS)
THEN
BEGIN
IF CH IN ['+','-']
THEN
BEGIN
LSWITCH := CH = '+'; NEXTCH
END
ELSE
REPEAT
LVALUE := LVALUE * 10 + (ORD(CH)-ORD('0'));
NEXTCH
UNTIL NOT (CH IN DIGITS);
IF NOT RESET←POSSIBLE AND (LCH IN ['S','R','X','F','I','U','E'])
THEN ERROR(203)
ELSE
CASE LCH OF
'L':
LIST←CODE := LSWITCH AND LPTFILE;
'U':
CHCNTMAX := 72;
'T':
RUNTIME←CHECK := LSWITCH;
'E':
IF PROGRAM←COUNT > 1
THEN ERROR(203)
ELSE EXTERNAL := LSWITCH;
'D','P':
IF RESET←POSSIBLE
THEN
BEGIN
DEBUG := LSWITCH;
DEBUG←SWITCH := LSWITCH
END
ELSE
IF DEBUG
THEN DEBUG←SWITCH := LSWITCH
ELSE ERROR(203);
'F':
IF LVALUE IN [1..MAX←FILE]
THEN START←CHANNEL := LVALUE + NAMAX[STDFILE] - 2
ELSE ERROR(203);
'R':
RUNCORE := LVALUE;
'X':
IF LVALUE IN [REGIN..WITHIN]
THEN PARREGCMAX := LVALUE
ELSE ERROR(203);
'S':
CODE←SIZE := LVALUE;
'I':
FORTRAN←ENVIROMENT := LSWITCH;
OTHERS:
IF LCH = 'B'
THEN ERROR(169)
ELSE ERROR(203)
END
END
ELSE ERROR(203);
IF EOLN(SOURCE)
THEN ENDOFLINE
UNTIL CH <> ','
END (*OPTIONS*) ;
BEGIN (*SKIPCOMMENT*)
COMMENTEND := FALSE; NEXTCH;
IF CH = '$'
THEN OPTIONS;
LOOP
WHILE CH = '*' DO
BEGIN
NEXTCH;
COMMENTEND := CH = ')'
END
EXIT IF (CH='\') OR COMMENTEND;
IF EOLN(SOURCE)
THEN ENDOFLINE;
NEXTCH
END (*LOOP*);
NEXTCH
END (*SKIPCOMMENT*);
BEGIN
(*INSYMBOL*)
WHILE CH = ' ' DO
BEGIN
IF EOLN(SOURCE)
THEN ENDOFLINE;
NEXTCH
END;
CASE CH OF
'%':
BEGIN
SKIPCOMMENT; INSYMBOL
END;
'(':
BEGIN
NEXTCH;
IF CH = '*'
THEN
BEGIN
SKIPCOMMENT; INSYMBOL
END
ELSE
BEGIN
SY := LPARENT; OP := NOOP
END
END;
'A','B','C','D','E','F','G','H','I','J','K','L','M',
'N','O','P','Q','R','S','T','U','V','W','X','Y',
'Z':
BEGIN
K := 0 ; ID := ' ';
REPEAT
IF K < ALFALENGTH
THEN
BEGIN
K := K + 1; ID[K] := CH
END ;
NEXTCH
UNTIL NOT (CH IN LETTERSDIGITSORLEFTARROW);
FOR I := FRW[K] TO FRW[K+1] - 1 DO
IF RW[I] = ID
THEN
BEGIN
SY := RSY[I];
OP := ROP[I];
IF (SY = INITPROCSY) AND NOT DP
THEN ERROR(363);
GOTO 222
END;
SY := IDENT; OP := NOOP;
222:
END;
'0','1','2','3','4','5','6','7','8',
'9':
BEGIN
SY := INTCONST; OP := NOOP;
ID := ' ';
I := 0;
REPEAT
I := I + 1;
(* THE DIGITS OF AN "INTCONST" ARE STORED AS "IDENT" TOO. THIS ALLOWES
TO ENTER "LABELS" LIKE ALL OTHER IDENTIFIERS INTO THE BINARY-
(IDENTIFIER-)TREE VIA "ENTERID" AND LOCATE THEM VIA
"SEARCHID". SO "LABELS" ARE "KNOWN" AS CONSTANTS, TYPES OR
VARIABLES IN THE BLOCK THEY HAVE BEEN DECLARED IN.
IT IS ALSO POSSIBLE TO "EXIT" FROM A BLOCK, JUMPING TO A LABEL
WHICH IS DECLARED ON A LOWER LEVEL *)
IF I <= ALFALENGTH
THEN ID[I] := CH;
IF I <= MAXDIGITS
THEN DIGIT[I] := ORD(CH) - ORD('0')
ELSE ERROR(174) ;
NEXTCH
UNTIL NOT (CH IN DIGITS);
IVAL := 0;
IF CH = 'B'
THEN
BEGIN
FOR K := 1 TO I DO
IF IVAL <= MAX8
THEN
BEGIN
IF DIGIT[K] IN [8,9]
THEN ERROR(252);
IVAL := 8*IVAL + DIGIT[K]
END
ELSE
IF (IVAL = TEST8) AND (DIGIT[12] = 0)
THEN IVAL := -MAXINT - 1
ELSE
BEGIN
ERROR(204); IVAL := 0
END;
VAL.IVAL := IVAL;
NEXTCH
END
ELSE
BEGIN
FOR K := 1 TO I DO
IF IVAL <= MAX10
THEN
IF (IVAL = MAX10) AND (DIGIT[K] > 7)
THEN
BEGIN
ERROR(204); IVAL := 0
END
ELSE IVAL := 10*IVAL + DIGIT[K]
ELSE
BEGIN
ERROR(204); IVAL := 0
END;
SCALE := 0;
IF CH = '.'
THEN
BEGIN
NEXTCH;
IF CH = '.'
THEN CH := ':'
ELSE
BEGIN
RVAL := IVAL; SY := REALCONST;
IF NOT (CH IN DIGITS)
THEN ERROR(205)
ELSE
REPEAT
RVAL := 10.0*RVAL + (ORD(CH) - ORD('0'));
SCALE := SCALE - 1; NEXTCH
UNTIL NOT (CH IN DIGITS)
END
END;
IF CH = 'E'
THEN
BEGIN
IF SCALE = 0
THEN
BEGIN
RVAL := IVAL; SY := REALCONST
END;
NEXTCH;
SIGN := CH='-';
IF (CH='+') OR SIGN
THEN NEXTCH;
EXPONENT := 0;
IF NOT (CH IN DIGITS)
THEN ERROR(205)
ELSE
REPEAT
EXPONENT := 10 * EXPONENT + ORD(CH) - ORD('0');
NEXTCH
UNTIL NOT (CH IN DIGITS);
IF SIGN
THEN SCALE := SCALE - EXPONENT
ELSE SCALE := SCALE + EXPONENT;
IF ABS(ROUND(SCALE/LOG←OF←2 + EXPO(RVAL))) >= MAXEXP2
THEN
BEGIN
ERROR(206); SCALE := 0
END
END;
IF SCALE <> 0
THEN
BEGIN
IF SCALE < 0
THEN
BEGIN
SCALE := ABS(SCALE); FAC := 0.1
END
ELSE FAC := 10.0;
R := 1.0;
LOOP
IF ODD(SCALE)
THEN R := R * FAC;
SCALE := SCALE DIV 2
EXIT IF SCALE = 0;
FAC := SQR(FAC)
END;
RVAL := RVAL * R (* RVAL := RVAL * 10 ** SCALE *)
END;
IF SY = INTCONST
THEN VAL.IVAL := IVAL
ELSE
BEGIN
NEW(LVP,REEL);
LVP↑.RVAL := RVAL; VAL.VALP := LVP
END
END
END;
'"':
BEGIN
SY := INTCONST; OP := NOOP; IVAL := 0;
NEXTCH;
WHILE (CH IN HEXADIGITS) AND (IVAL >= 0) DO
BEGIN
IF IVAL <= MAX16
THEN
IF CH IN DIGITS
THEN IVAL := 16*IVAL + (ORD(CH) - ORD('0'))
ELSE IVAL := 16*IVAL + (ORD(CH) - 67B)
ELSE
IF (IVAL = TEST16) AND (CH = '0')
THEN IVAL := -MAXINT - 1
ELSE
BEGIN
ERROR(174); IVAL := 0
END;
NEXTCH
END;
WHILE CH IN HEXADIGITS DO NEXTCH;
VAL.IVAL := IVAL
END;
'''':
BEGIN
LGTH := 0; SY := STRINGCONST; OP := NOOP; STRINGTOOLONG := FALSE;
REPEAT
REPEAT
NEXTCH;
IF LGTH <= STRGLGTH
THEN
BEGIN
LGTH := LGTH + 1;
IF LGTH <= STRGLGTH
THEN STRING[LGTH] := CH
END
ELSE STRINGTOOLONG := TRUE
UNTIL EOLN(SOURCE) OR (CH = '''');
IF STRINGTOOLONG
THEN ERROR(301);
IF CH <> ''''
THEN ERROR(351)
ELSE NEXTCH
UNTIL CH <> '''';
LGTH := LGTH - 1;
IF LGTH = 1
THEN VAL.IVAL := ORD(STRING[1])
ELSE
BEGIN
NEW(LVP,STRG:LGTH);
WITH LVP↑ DO
BEGIN
SLGTH := LGTH;
PACK(STRING,1,SVAL,1,LGTH)
END;
VAL.VALP := LVP
END
END;
':':
BEGIN
OP := NOOP; NEXTCH;
IF CH = '='
THEN
BEGIN
SY := BECOMES; NEXTCH
END
ELSE SY := COLON
END;
'.':
BEGIN
OP := NOOP; NEXTCH;
IF CH = '.'
THEN
BEGIN
SY := COLON; NEXTCH
END
ELSE SY := PERIOD
END;
'<','>':
BEGIN
SY := RELOP; OP := SOP[CH]; NEXTCH;
IF (OP=LTOP) AND (CH='>')
THEN
BEGIN
OP := NEOP; NEXTCH
END
ELSE
IF CH = '='
THEN
BEGIN
IF OP = LTOP
THEN OP := LEOP
ELSE OP := GEOP;
NEXTCH
END
END;
OTHERS:
BEGIN
SY := SSY[CH]; OP := SOP[CH];
NEXTCH
END
END (*CASE*);
FIRST←SYMBOL := FALSE
END (*INSYMBOL*) ;
PROCEDURE SEARCHSECTION(FCP: CTP; VAR FCP1: CTP);
(*TO FIND RECORD FIELDS AND FORWARD DECLARED PROCEDURE ID'S
--> PROCEDURE PROCEDUREDECLARATION
--> PROCEDURE SELECTOR*)
LABEL
333;
BEGIN
WHILE FCP <> NIL DO
WITH FCP↑ DO
BEGIN
IF NAME = ID
THEN GOTO 333;
IF NAME < ID
THEN FCP := RLINK
ELSE FCP := LLINK
END;
333:
FCP1 := FCP
END (*SEARCHSECTION*) ;
PROCEDURE SEARCHID(FIDCLS: SETOFIDS; VAR FCP: CTP);
LABEL
444;
VAR
LCP: CTP;
BEGIN
FOR DISX := TOP DOWNTO 0 DO
BEGIN
LCP := DISPLAY[DISX].FNAME;
WHILE LCP <> NIL DO
WITH LCP↑ DO
IF NAME = ID
THEN
IF KLASS IN FIDCLS
THEN GOTO 444
ELSE
BEGIN
IF SEARCH←ERROR
THEN ERROR(401);
LCP := RLINK
END
ELSE
IF NAME < ID
THEN LCP := RLINK
ELSE LCP := LLINK
END;
(*SEARCH NOT SUCCSESSFUL; SUPPRESS ERROR MESSAGE IN CASE
OF FORWARD REFERENCED TYPE ID IN POINTER TYPE DEFINITION
--> PROCEDURE SIMPLETYPE*)
IF SEARCH←ERROR
THEN
BEGIN
IF ID[1] IN DIGITS
THEN ERROR(215) (*UNDECLARED LABEL*)
ELSE ERROR(253) (*UNDECLARED IDENTIFIER*);
(*TO AVOID RETURNING NIL, REFERENCE AN ENTRY
FOR AN UNDECLARED ID OF APPROPRIATE CLASS
--> PROCEDURE ENTERUNDECL*)
IF TYPES IN FIDCLS
THEN LCP := UTYPPTR
ELSE
IF VARS IN FIDCLS
THEN LCP := UVARPTR
ELSE
IF FIELD IN FIDCLS
THEN LCP := UFLDPTR
ELSE
IF KONST IN FIDCLS
THEN LCP := UCSTPTR
ELSE
IF PROC IN FIDCLS
THEN LCP := UPRCPTR
ELSE LCP := UFCTPTR
END;
444:
FCP := LCP
END (*SEARCHID*) ;
PROCEDURE SKIPIFERR(FSYINSYS:SETOFSYS; FERRNR:INTEGER; FSKIPSYS: SETOFSYS);
VAR
I,OLDCHCNT,OLDLINECNT : INTEGER;
BEGIN
IF NOT (SY IN FSYINSYS)
THEN
BEGIN
ERROR(FERRNR);
OLDLINECNT := LINECNT; OLDCHCNT := CHCNT;
WHILE NOT (SY IN FSKIPSYS + FSYINSYS) DO
BEGIN
(*SKIP INPUT STRING UNTIL RELEVANT SYMBOL FOUND*)
IF OLDLINECNT <> LINECNT
THEN OLDCHCNT := 1;
FOR I := OLDCHCNT TO CHCNT-1 DO
IF I <= CHCNTMAX
THEN ERRLINE [I] := '*';
OLDCHCNT := CHCNT; OLDLINECNT := LINECNT; ERRORINLINE := TRUE;
INSYMBOL
END
END;
FOLLOWERROR := FALSE
END;
PROCEDURE IFERRSKIP(FERRNR: INTEGER; FSYS: SETOFSYS);
BEGIN
SKIPIFERR(FSYS,FERRNR,FSYS)
END;
PROCEDURE ERRANDSKIP(FERRNR: INTEGER; FSYS: SETOFSYS);
BEGIN
SKIPIFERR([ ],FERRNR,FSYS)
END;
PROCEDURE BLOCK(FPROCP: CTP; FSYS,LEAVEBLOCKSYS: SETOFSYS);
TYPE
MARKER = ↑INTEGER;
VAR
LSY: SYMBOL; CURRENT←JUMP: 0..JUMP←MAX;
TESTPACKED: BOOLEAN;
LCPAR: ADDRRANGE;
HEAPMARK, GLOBMARK: MARKER;
FORWARD←PROCEDURES : CTP;
PROCEDURE CONSTANT(FSYS: SETOFSYS; VAR FSP: STP; VAR FVALU: VALU);
VAR
LSP, LSP1: STP;
LCP: CTP;
SIGN: (NONE,POS,NEG);
BEGIN
LSP := NIL; FVALU.IVAL := 0;
SKIPIFERR(CONSTBEGSYS,207,FSYS);
IF SY IN CONSTBEGSYS
THEN
BEGIN
IF SY = STRINGCONST
THEN
BEGIN
IF LGTH = 1
THEN LSP := ASCIIPTR
ELSE
IF LGTH = ALFALENGTH
THEN LSP := ALFAPTR
ELSE
BEGIN
NEW(LSP,ARRAYS); NEW(LSP1,SUBRANGE);
WITH LSP↑ DO
BEGIN
SELFSTP := NIL; AELTYPE := ASCIIPTR; INXTYPE := LSP1;
SIZE := (LGTH+4) DIV 5; ARRAYPF := TRUE;
BITSIZE := BITMAX
END;
WITH LSP1↑ DO
BEGIN
SELFSTP := NIL; SIZE := 1; BITSIZE := BITMAX;
VMIN.IVAL := 1; VMAX.IVAL := LGTH; RANGETYPE := INTPTR
END
END;
FVALU := VAL; INSYMBOL
END
ELSE
BEGIN
SIGN := NONE;
IF (SY = ADDOP) AND (OP IN [PLUS,MINUS])
THEN
BEGIN
IF OP = PLUS
THEN SIGN := POS
ELSE SIGN := NEG;
INSYMBOL
END;
IF SY = IDENT
THEN
BEGIN
SEARCHID([KONST],LCP);
WITH LCP↑ DO
BEGIN
LSP := IDTYPE; FVALU := VALUES
END;
IF SIGN <> NONE
THEN
IF LSP = INTPTR
THEN
BEGIN
IF SIGN = NEG
THEN FVALU.IVAL := -FVALU.IVAL
END
ELSE
IF LSP = REALPTR
THEN
BEGIN
IF SIGN = NEG
THEN
FVALU.VALP↑.RVAL := -FVALU.VALP↑.RVAL
END
ELSE ERROR(167);
INSYMBOL
END
ELSE
IF SY = INTCONST
THEN
BEGIN
IF SIGN = NEG
THEN VAL.IVAL := -VAL.IVAL;
LSP := INTPTR; FVALU := VAL; INSYMBOL
END
ELSE
IF SY = REALCONST
THEN
BEGIN
IF SIGN = NEG
THEN VAL.VALP↑.RVAL := -VAL.VALP↑.RVAL;
LSP := REALPTR; FVALU := VAL; INSYMBOL
END
ELSE ERRANDSKIP(168,FSYS)
END;
IFERRSKIP(166,FSYS)
END;
FSP := LSP
END (*CONSTANT*) ;
PROCEDURE GETBOUNDS(FSP: STP; VAR FMIN, FMAX: INTEGER); FORWARD;
FUNCTION COMPTYPES(FSP1,FSP2: STP) : BOOLEAN;
(*DECIDE WHETHER STRUCTURES POINTED AT BY FSP1 AND FSP2 ARE COMPATIBLE*)
VAR
NXT1,NXT2: CTP; COMP: BOOLEAN; LMIN,LMAX,I: INTEGER;
LTESTP1,LTESTP2: TESTP;
BEGIN
IF FSP1 = FSP2
THEN COMPTYPES := TRUE
ELSE
IF (FSP1 <> NIL) AND (FSP2 <> NIL)
THEN
IF FSP1↑.FORM = FSP2↑.FORM
THEN
CASE FSP1↑.FORM OF
SCALAR:
COMPTYPES := FALSE;
(* IDENTICAL SCALARS DECLARED ON DIFFERENT LEVELS ARE
NOT RECOGNIZED TO BE COMPATIBLE*)
SUBRANGE:
COMPTYPES := COMPTYPES(FSP1↑.RANGETYPE,FSP2↑.RANGETYPE);
POINTER:
BEGIN
COMP := FALSE; LTESTP1 := GLOBTESTP; LTESTP2 := GLOBTESTP;
WHILE LTESTP1 <> NIL DO
WITH LTESTP1↑ DO
BEGIN
IF (ELT1 = FSP1↑.ELTYPE) AND (ELT2 = FSP2↑.ELTYPE)
THEN COMP := TRUE;
LTESTP1 := LASTTESTP
END;
IF NOT COMP
THEN
BEGIN
NEW(LTESTP1);
WITH LTESTP1↑ DO
BEGIN
ELT1 := FSP1↑.ELTYPE;
ELT2 := FSP2↑.ELTYPE;
LASTTESTP := GLOBTESTP
END;
GLOBTESTP := LTESTP1; COMP := COMPTYPES(FSP1↑.ELTYPE,FSP2↑.ELTYPE)
END;
COMPTYPES := COMP; GLOBTESTP := LTESTP2
END;
POWER:
COMPTYPES := COMPTYPES(FSP1↑.ELSET,FSP2↑.ELSET);
ARRAYS:
BEGIN
GETBOUNDS(FSP1↑.INXTYPE,LMIN,LMAX);
I := LMAX-LMIN;
GETBOUNDS(FSP2↑.INXTYPE,LMIN,LMAX);
COMPTYPES := COMPTYPES(FSP1↑.AELTYPE,FSP2↑.AELTYPE)
AND (FSP1↑.ARRAYPF = FSP2↑.ARRAYPF) AND ( I = LMAX - LMIN ) ;
END;
RECORDS:
BEGIN
NXT1 := FSP1↑.FSTFLD; NXT2 := FSP2↑.FSTFLD; COMP := TRUE;
WHILE (NXT1 <> NIL) AND (NXT2 <> NIL) DO
BEGIN
COMP := COMPTYPES(NXT1↑.IDTYPE,NXT2↑.IDTYPE) AND COMP;
NXT1 := NXT1↑.NEXT; NXT2 := NXT2↑.NEXT
END;
COMPTYPES := COMP AND (NXT1 = NIL) AND (NXT2 = NIL)
AND (FSP1↑.RECVAR = NIL) AND (FSP2↑.RECVAR = NIL)
END;
(*IDENTICAL RECORDS ARE RECOGNIZED TO BE COMPATIBLE
IF NO VARIANTS OCCUR*)
FILES:
COMPTYPES := COMPTYPES(FSP1↑.FILTYPE,FSP2↑.FILTYPE)
END (*CASE*)
ELSE (*FSP1↑.FORM <> FSP2↑.FORM*)
IF FSP1↑.FORM = SUBRANGE
THEN COMPTYPES := COMPTYPES(FSP1↑.RANGETYPE,FSP2)
ELSE
IF FSP2↑.FORM = SUBRANGE
THEN COMPTYPES := COMPTYPES(FSP1,FSP2↑.RANGETYPE)
ELSE COMPTYPES := FALSE
ELSE COMPTYPES := TRUE
END (*COMPTYPES*) ;
PROCEDURE GETBOUNDS;
(*GET INTERNAL BOUNDS OF SUBRANGE OR SCALAR TYPE*)
BEGIN
FMIN := 0; FMAX := 0;
IF FSP <> NIL
THEN
IF FSP = INTPTR
THEN
BEGIN (* TYPE INTEGER = MININT..MAXINT *)
FMIN := -MAXINT - 1;
FMAX := MAXINT
END
ELSE
IF (FSP↑.FORM <= SUBRANGE) AND NOT COMPTYPES(REALPTR,FSP)
THEN
WITH FSP↑ DO
IF FORM = SUBRANGE
THEN
BEGIN
FMIN := VMIN.IVAL;
FMAX := VMAX.IVAL
END
ELSE
IF FSP = ASCIIPTR
THEN
BEGIN (* TYPE ASCII = NUL..DEL *)
FMIN := ORD(NUL);
FMAX := ORD(DEL)
END
ELSE
IF FCONST <> NIL
THEN FMAX := FCONST↑.VALUES.IVAL
ELSE FMAX := 0
END (*GETBOUNDS*) ;
FUNCTION STRING(FSP: STP) : BOOLEAN;
BEGIN
STRING := FALSE;
IF FSP <> NIL
THEN
IF FSP↑.FORM = ARRAYS
THEN STRING := COMPTYPES(FSP↑.AELTYPE,ASCIIPTR)
END (*STRING*) ;
PROCEDURE TYP(FSYS: SETOFSYS; VAR FSP: STP; VAR FSIZE: ADDRRANGE;
VAR FBITSIZE: BITRANGE);
VAR
LSP,LSP1,LSP2: STP; OLDTOP: DISPRANGE; LCP: CTP;
LSIZE,DISPL: ADDRRANGE; I,LMIN,LMAX: INTEGER;
PACKFLAG: BOOLEAN; LBITSIZE: BITRANGE;
LBTP: BTP; BITCOUNT:INTEGER; BYTES: BITRANGE;
FUNCTION LOG2(FVAL: INTEGER): BITRANGE;
VAR
E: BITRANGE; H: INTEGER;
BEGIN
E := 0; H := 1;
REPEAT
E := E + 1; H := H * 2
UNTIL FVAL <= H;
LOG2 := E
END (*LOG2*);
PROCEDURE SIMPLETYPE(FSYS: SETOFSYS; VAR FSP: STP; VAR FSIZE: ADDRRANGE;
VAR FBITSIZE: BITRANGE);
VAR
LSP,LSP1: STP; LCP,LCP1: CTP; TTOP: DISPRANGE;
LCNT: INTEGER; LVALU: VALU; LBITSIZE: BITRANGE;
BEGIN
FSIZE := 1;
SKIPIFERR(SIMPTYPEBEGSYS,208,FSYS);
IF SY IN SIMPTYPEBEGSYS
THEN
BEGIN (* DECLARED SCALARS *)
IF SY = LPARENT
THEN
BEGIN
TTOP := TOP;
WHILE DISPLAY[TOP].OCCUR <> BLCK DO TOP := TOP - 1;
NEW(LSP,SCALAR,DECLARED);
LCP1 := NIL; LCNT := 0;
REPEAT
INSYMBOL;
IF SY = IDENT
THEN
BEGIN
NEW(LCP,KONST);
WITH LCP↑ DO
BEGIN
NAME := ID; IDTYPE := LSP; NEXT := LCP1;
VALUES.IVAL := LCNT
END;
ENTERID(LCP);
LCNT := LCNT + 1;
LCP1 := LCP; INSYMBOL
END
ELSE ERROR(209);
IFERRSKIP(166,FSYS + [COMMA,RPARENT])
UNTIL SY <> COMMA;
TOP := TTOP;
WITH LSP↑ DO
BEGIN
SELFSTP := NIL; FCONST := LCP1; SIZE := 1; BITSIZE := LOG2(LCNT);
(*ADDITIONAL INFORMATION NEEDED TO STORE IDENTS OF DECLARED
SCALARS USED BY READ AND WRITE*)
VECTORCHAIN := 0; DIMENSION := LCNT - 1; REQUEST := FALSE;
NEXTSCALAR := DECLSCALPTR; DECLSCALPTR := LSP;
VECTORADDR := 0; TLEV := LEVEL
END;
IF SY = RPARENT
THEN INSYMBOL
ELSE ERROR(152)
END (* SY = LPARENT *)
ELSE
BEGIN (* DEFINED CONSTANTS *)
IF SY = IDENT
THEN
BEGIN
SEARCHID([TYPES,KONST],LCP);
INSYMBOL;
IF LCP↑.KLASS = KONST
THEN
BEGIN
NEW(LSP,SUBRANGE);
WITH LSP↑, LCP↑ DO
BEGIN
SELFSTP := NIL; RANGETYPE := IDTYPE;
IF STRING(RANGETYPE)
THEN
BEGIN
ERROR(303); RANGETYPE := NIL
END;
VMIN := VALUES; SIZE := 1
END;
IF SY = COLON
THEN INSYMBOL
ELSE ERROR(151);
CONSTANT(FSYS,LSP1,LVALU);
WITH LSP↑ DO
BEGIN
VMAX := LVALU;
IF (VMIN.IVAL < 0) OR (RANGETYPE = REALPTR)
THEN BITSIZE := BITMAX
ELSE
IF VMAX.IVAL = MAXINT
THEN BITSIZE := BITMAX
ELSE BITSIZE := LOG2(VMAX.IVAL + 1);
IF NOT COMPTYPES(RANGETYPE,LSP1)
THEN ERROR(304)
END
END
ELSE
BEGIN
LSP := LCP↑.IDTYPE;
IF LSP <> NIL
THEN FSIZE := LSP↑.SIZE
END
END (*SY = IDENT*)
ELSE (* SELF-DEFINING CONSTANTS *)
BEGIN
NEW(LSP,SUBRANGE);
CONSTANT(FSYS + [COLON],LSP1,LVALU);
IF STRING(LSP1)
THEN
BEGIN
ERROR(303); LSP1 := NIL
END;
WITH LSP↑ DO
BEGIN
RANGETYPE := LSP1; VMIN := LVALU; SIZE := 1
END;
IF SY = COLON
THEN INSYMBOL
ELSE ERROR(151);
CONSTANT(FSYS,LSP1,LVALU);
WITH LSP↑ DO
BEGIN
SELFSTP := NIL; VMAX := LVALU;
IF (VMIN.IVAL < 0) OR (RANGETYPE = REALPTR)
THEN BITSIZE := BITMAX
ELSE
IF VMAX.IVAL = MAXINT
THEN BITSIZE := BITMAX
ELSE BITSIZE := LOG2(VMAX.IVAL + 1);
IF NOT COMPTYPES(RANGETYPE,LSP1)
THEN ERROR(304)
END
END;
IF LSP <> NIL
THEN WITH LSP↑ DO
IF FORM = SUBRANGE
THEN
IF RANGETYPE <> NIL
THEN
IF RANGETYPE = REALPTR
THEN
BEGIN
IF VMIN.VALP↑.RVAL > VMAX.VALP↑.RVAL
THEN ERROR(451)
END
ELSE
IF VMIN.IVAL > VMAX.IVAL
THEN ERROR(451)
END;
FSP := LSP;
IF LSP<>NIL
THEN FBITSIZE := LSP↑.BITSIZE
ELSE FBITSIZE := 0;
IFERRSKIP(166,FSYS)
END
ELSE
BEGIN
FSP := NIL; FBITSIZE := 0
END
END (*SIMPLETYPE*) ;
PROCEDURE FIELDLIST(FSYS: SETOFSYS; VAR FRECVAR: STP; VAR FFIRSTFIELD: CTP);
LABEL
555,5551;
VAR
LCP,LCP1,NXT,NXT1: CTP; LSP,LSP1,LSP2,LSP3,LSP4,TAGSP: STP;
MINSIZE,MAXSIZE,LSIZE: ADDRRANGE; LVALU: VALU;
LBITSIZE: BITRANGE;
LBTP: BTP; MINBITCOUNT:INTEGER;
LID : ALFA ;
PROCEDURE RECSECTION( VAR FCP: CTP; FSP: STP );
BEGIN
IF NOT PACKFLAG OR (LSIZE > 1) OR (LBITSIZE = 36)
THEN
BEGIN
IF BITCOUNT > 0
THEN
BEGIN
DISPL := DISPL + 1; BITCOUNT := 0
END;
WITH FCP↑ DO
BEGIN
IDTYPE := FSP; FLDADDR := DISPL;
PACKF := NOTPACK; FCP := NEXT;
DISPL := DISPL + LSIZE
END
END
ELSE (*PACKED RECORDS*)
BEGIN
BITCOUNT := BITCOUNT + LBITSIZE;
IF BITCOUNT>BITMAX
THEN
BEGIN
DISPL := DISPL + 1;
BITCOUNT := LBITSIZE
END;
IF (LBITSIZE = 18) AND (BITCOUNT IN [18,36])
THEN
BEGIN
WITH FCP↑ DO
BEGIN
IDTYPE := FSP;
FLDADDR := DISPL;
IF BITCOUNT = 18
THEN PACKF := HWORDL
ELSE PACKF := HWORDR;
FCP := NEXT
END
END
ELSE
WITH FCP↑, FLDBYTE DO
BEGIN
SBITS := LBITSIZE;
PBITS := BITMAX - BITCOUNT;
RELADDR := DISPL;
DUMMYBIT := 0;
IBIT := 0;
IDTYPE := FSP;
PACKF := PACKK;
FCP := NEXT
END
END
END (* RECSECTION *) ;
BEGIN
NXT1 := NIL; LSP := NIL;
SKIPIFERR([IDENT,CASESY],452,FSYS);
WHILE SY = IDENT DO
BEGIN
NXT := NXT1;
LOOP
IF SY = IDENT
THEN
BEGIN
NEW(LCP,FIELD);
WITH LCP↑ DO
BEGIN
NAME := ID; IDTYPE := NIL; NEXT := NXT
END;
NXT := LCP;
ENTERID(LCP);
INSYMBOL
END
ELSE ERROR(209);
SKIPIFERR([COMMA,COLON],166,FSYS + [SEMICOLON,CASESY])
EXIT IF SY <> COMMA ;
INSYMBOL
END;
IF SY = COLON
THEN INSYMBOL
ELSE ERROR(151);
TYP(FSYS + [CASESY,SEMICOLON],LSP,LSIZE,LBITSIZE);
IF LSP <> NIL
THEN
IF LSP↑.FORM = FILES
THEN ERROR(254);
(* RESERVE SPACE FOR ONE RECORD SECTION *)
WHILE NXT <> NXT1 DO
RECSECTION(NXT,LSP);
NXT1 := LCP;
IF SY = SEMICOLON
THEN
BEGIN
INSYMBOL;
SKIPIFERR([IDENT,ENDSY,CASESY],452,FSYS)
END
ELSE SKIPIFERR([ENDSY,RPARENT],156,FSYS)
END (*WHILE*);
NXT := NIL;
WHILE NXT1 <> NIL DO
WITH NXT1↑ DO
BEGIN
LCP := NEXT; NEXT := NXT; NXT := NXT1; NXT1 := LCP
END;
FFIRSTFIELD := NXT;
IF SY = CASESY
THEN
BEGIN
LCP:=NIL; (*POSSIBILITY OF NO TAGFIELD IDENTIFIER*)
INSYMBOL;
IF SY = IDENT
THEN
BEGIN
LID := ID ;
INSYMBOL ;
IF (SY<>COLON) AND (SY<>OFSY)
THEN
BEGIN
ERROR(151) ;
ERRANDSKIP(160,FSYS + [LPARENT])
END
ELSE
BEGIN
IF SY = COLON
THEN
BEGIN
NEW(LSP,TAGFWITHID);
NEW(LCP,FIELD) ;
WITH LCP↑ DO
BEGIN
NAME := LID ; IDTYPE := NIL ; NEXT := NIL
END ;
ENTERID(LCP) ;
INSYMBOL ;
IF SY <> IDENT
THEN
BEGIN
ERRANDSKIP(209,FSYS + [LPARENT]) ; GOTO 555
END
ELSE
BEGIN
LID := ID ;
INSYMBOL ;
IF SY <> OFSY
THEN
BEGIN
ERRANDSKIP(160,FSYS + [LPARENT]) ; GOTO 555
END
END
END
ELSE NEW(LSP,TAGFWITHOUTID) ;
WITH LSP↑ DO
BEGIN
SIZE:= 0 ; SELFSTP := NIL ;
FSTVAR := NIL;
IF FORM=TAGFWITHID
THEN TAGFIELDP:=NIL
ELSE TAGFIELDTYPE := NIL
END;
FRECVAR := LSP;
ID := LID ;
SEARCHID([TYPES],LCP1) ;
TAGSP := LCP1↑.IDTYPE;
IF TAGSP <> NIL
THEN
IF (TAGSP↑.FORM <= SUBRANGE) OR STRING(TAGSP)
THEN
BEGIN
IF COMPTYPES(REALPTR,TAGSP)
THEN ERROR(210)
ELSE
IF STRING(TAGSP)
THEN ERROR(169);
WITH LSP↑ DO
BEGIN
BITSIZE := TAGSP↑.BITSIZE;
IF FORM = TAGFWITHID
THEN TAGFIELDP := LCP
ELSE TAGFIELDTYPE := TAGSP
END;
IF LCP <> NIL
THEN
BEGIN
LBITSIZE :=TAGSP↑.BITSIZE;
LSIZE := TAGSP↑.SIZE;
RECSECTION(LCP,TAGSP); (*RESERVES SPACE FOR THE TAGFIELD *)
IF BITCOUNT > 0
THEN LSP↑.SIZE := DISPL + 1
ELSE LSP↑.SIZE := DISPL
END
END
ELSE ERROR(402);
INSYMBOL
END
END
ELSE ERRANDSKIP(209,FSYS + [LPARENT]) ;
555:
LSP1 := NIL; MINSIZE := DISPL; MAXSIZE := DISPL; MINBITCOUNT:=BITCOUNT;
LOOP
LSP2 := NIL;
LOOP
CONSTANT(FSYS + [COMMA,COLON,LPARENT],LSP3,LVALU);
IF NOT COMPTYPES(TAGSP,LSP3)
THEN ERROR(305);
NEW(LSP3,VARIANT);
WITH LSP3↑ DO
BEGIN
NXTVAR := LSP1; SUBVAR := LSP2; VARVAL := LVALU;
BITSIZE := LSP↑.BITSIZE; SELFSTP := NIL
END;
LSP1 := LSP3; LSP2 := LSP3
EXIT IF SY <> COMMA;
INSYMBOL
END;
IF SY = COLON
THEN INSYMBOL
ELSE ERROR(151);
IF SY = LPARENT
THEN INSYMBOL
ELSE ERROR(153);
FIELDLIST(FSYS + [RPARENT,SEMICOLON],LSP2,LCP);
IF BITCOUNT > 0
THEN
BEGIN
DISPL := DISPL + 1 ; BITCOUNT := 0
END ;
IF DISPL > MAXSIZE
THEN MAXSIZE := DISPL;
WHILE LSP3 <> NIL DO
BEGIN
LSP4 := LSP3↑.SUBVAR; LSP3↑.SUBVAR := LSP2; LSP3↑.FIRSTFIELD := LCP;
LSP3↑.SIZE := DISPL ;
LSP3 := LSP4
END;
IF SY = RPARENT
THEN
BEGIN
INSYMBOL;
IFERRSKIP(166,FSYS + [SEMICOLON])
END
ELSE ERROR(152)
EXIT IF SY <> SEMICOLON;
INSYMBOL;
IF SY = ENDSY
THEN GOTO 5551;
DISPL := MINSIZE;
BITCOUNT:=MINBITCOUNT
END;
5551:
DISPL := MAXSIZE;
LSP↑.FSTVAR := LSP1
END (*IF SY = CASESY*)
ELSE
IF LSP <> NIL
THEN
IF LSP↑.FORM = ARRAYS
THEN FRECVAR := LSP
ELSE FRECVAR := NIL
END (*FIELDLIST*) ;
BEGIN
(*TYP*)
SKIPIFERR(TYPEBEGSYS,170,FSYS);
IF SY IN TYPEBEGSYS
THEN
BEGIN
IF SY IN SIMPTYPEBEGSYS
THEN SIMPLETYPE(FSYS,FSP,FSIZE,FBITSIZE)
ELSE
IF SY = ARROW
THEN
BEGIN
NEW(LSP,POINTER); FSP := LSP;
LBITSIZE := 18;
WITH LSP↑ DO
BEGIN
SELFSTP := NIL; ELTYPE := NIL; SIZE := 1; BITSIZE := LBITSIZE
END;
INSYMBOL;
IF SY = IDENT
THEN
BEGIN
SEARCH←ERROR := FALSE;
SEARCHID([TYPES],LCP);
SEARCH←ERROR := TRUE;
IF LCP = NIL
THEN (*FORWARD REFERENCED TYPE ID*)
BEGIN
NEW(LCP,TYPES);
WITH LCP↑ DO
BEGIN
NAME := ID; IDTYPE := LSP;
NEXT := FORWARD←POINTER←TYPE
END;
FORWARD←POINTER←TYPE := LCP
END
ELSE
BEGIN
IF LCP↑.IDTYPE <> NIL
THEN
IF LCP↑.IDTYPE↑.FORM = FILES
THEN ERROR(254)
ELSE LSP↑.ELTYPE := LCP↑.IDTYPE
END;
INSYMBOL;
FBITSIZE:=18
END
ELSE ERROR(209)
END
ELSE
BEGIN
IF SY = SEGMENTSY
THEN
BEGIN
INSYMBOL;
SKIPIFERR(TYPEDELS + [PACKEDSY],170,FSYS)
END;
IF SY = PACKEDSY
THEN
BEGIN
INSYMBOL;
SKIPIFERR(TYPEDELS,170,FSYS);
PACKFLAG := TRUE
END
ELSE PACKFLAG := FALSE;
CASE SY OF
ARRAYSY:
BEGIN
INSYMBOL;
IF SY = LBRACK
THEN INSYMBOL
ELSE ERROR(154);
LSP1 := NIL;
LOOP
NEW(LSP,ARRAYS);
WITH LSP↑ DO
BEGIN
AELTYPE := LSP1; INXTYPE := NIL; SELFSTP := NIL;
ARRAYPF := PACKFLAG; SIZE := 1
END;
LSP1 := LSP;
SIMPLETYPE(FSYS + [COMMA,RBRACK,OFSY],LSP2,LSIZE,LBITSIZE);
IF LSP2 <> NIL
THEN
IF LSP2↑.FORM <= SUBRANGE
THEN
BEGIN
IF LSP2 = REALPTR
THEN
BEGIN
ERROR(210); LSP2 := NIL
END
ELSE
IF LSP2 = INTPTR
THEN
BEGIN
ERROR(306); LSP2 := NIL
END;
LSP↑.INXTYPE := LSP2
END
ELSE
BEGIN
ERROR(403); LSP2 := NIL
END
EXIT IF SY <> COMMA;
INSYMBOL
END;
IF SY = RBRACK
THEN INSYMBOL
ELSE ERROR(155);
IF SY = OFSY
THEN INSYMBOL
ELSE ERROR(160);
TYP(FSYS,LSP,LSIZE,LBITSIZE);
IF LSP <> NIL
THEN
IF LSP↑.FORM = FILES
THEN ERROR(169) ;
REPEAT
WITH LSP1↑ DO
BEGIN
LSP2 := AELTYPE; AELTYPE := LSP;
IF INXTYPE <> NIL
THEN
BEGIN
GETBOUNDS(INXTYPE,LMIN,LMAX);
I := LMAX - LMIN + 1;
IF ARRAYPF AND (LBITSIZE<=18)
THEN
BEGIN
BYTES := BITMAX DIV LBITSIZE;
WITH ARRAYBPS[LBITSIZE] DO
IF STATE = USED
THEN ARRAYBPADDR := ADDRESS
ELSE
BEGIN
NEW(LBTP);
WITH LBTP↑ DO
BEGIN
LAST := LASTBTP; BITSIZE := LBITSIZE;
BYTEMAX := BYTES + 1 (*ONE MORE BYTEPOINTER USED FOR INCREMENT-OPERATIONS*) ;
ARRAYSP := LSP1
END;
LASTBTP := LBTP;
IF STATE = UNUSED
THEN
BEGIN
STATE := REQUESTED;
WITH ABYTE DO
BEGIN
SBITS := LBITSIZE;
PBITS := BITMAX; DUMMYBIT := 0;
IBIT := 0; IREG := REG1; RELADDR := 0
END
END
END;
LSIZE := (I+BYTES-1) DIV (BYTES)
END
ELSE
BEGIN
LSIZE := LSIZE * I;
ARRAYPF := FALSE
END;
LBITSIZE := BITMAX;
BITSIZE := LBITSIZE;
SIZE := LSIZE
END
END;
LSP := LSP1; LSP1 := LSP2
UNTIL LSP1 = NIL
END;
RECORDSY:
BEGIN
INSYMBOL;
OLDTOP := TOP;
IF TOP < DISPLIMIT
THEN
BEGIN
TOP := TOP + 1; DISPLAY[TOP].FNAME := NIL ;
DISPLAY[TOP].OCCUR := CREC ;
END
ELSE ERROR(404);
DISPL := 0; BITCOUNT := 0;
FIELDLIST(FSYS-[SEMICOLON] + [ENDSY],LSP1,LCP);
LBITSIZE := BITMAX;
NEW(LSP,RECORDS);
WITH LSP↑ DO
BEGIN
SELFSTP := NIL;
FSTFLD := (*LCP;*) DISPLAY[TOP].FNAME;
RECVAR := LSP1;
IF BITCOUNT > 0
THEN SIZE := DISPL + 1
ELSE SIZE := DISPL;
BITSIZE := LBITSIZE; RECORDPF := PACKFLAG
END;
TOP := OLDTOP;
IF SY = ENDSY
THEN INSYMBOL
ELSE ERROR(163)
END;
SETSY:
BEGIN
INSYMBOL;
IF SY = OFSY
THEN INSYMBOL
ELSE ERROR(160);
SIMPLETYPE(FSYS,LSP1,LSIZE,LBITSIZE);
IF LSP1 <> NIL
THEN
WITH LSP1↑ DO
CASE FORM OF
SCALAR:
IF SCALKIND = STANDARD
THEN ERROR(268)
ELSE
IF FCONST↑.VALUES.IVAL > BASEMAX
THEN ERROR(268);
SUBRANGE:
IF COMPTYPES(RANGETYPE,ASCIIPTR)
THEN
BEGIN
IF ((VMAX.IVAL-OFFSET) > BASEMAX) OR ((VMIN.IVAL-OFFSET) < 0)
THEN ERROR(268)
END
ELSE
BEGIN
IF (RANGETYPE = REALPTR) OR
((VMAX.IVAL > BASEMAX) OR (VMIN.IVAL < 0))
THEN ERROR(268)
END;
OTHERS:
BEGIN
ERROR(461); LSP1 := NIL
END
END;
LBITSIZE := BITMAX;
NEW(LSP,POWER);
WITH LSP↑ DO
BEGIN
SELFSTP := NIL; ELSET := LSP1; SIZE:=2; BITSIZE := LBITSIZE
END
END;
FILESY:
BEGIN
INSYMBOL;
IF SY = OFSY
THEN INSYMBOL
ELSE ERROR(160);
TYP(FSYS,LSP1,LSIZE,LBITSIZE);
NEW(LSP,FILES);
LBITSIZE := BITMAX;
WITH LSP↑ DO
BEGIN
SELFSTP := NIL;
FILTYPE := LSP1; SIZE := LSIZE+SIZEOFFILEBLOCK;
FILEPF := PACKFLAG; BITSIZE := LBITSIZE ;
(* REFER TO PROCEDURE "CODE←FOR←FILEBLOCKS"
IN "WRITE←MACHINE←CODE" *)
FILE←MODE := BINARY←MODE;
FILE←FORM := DATA←FILE;
IF COMPTYPES(FILTYPE,ASCIIPTR) AND FILEPF
THEN
BEGIN
FILE←MODE := ASCII←MODE;
IF FILTYPE <> NIL
THEN
WITH FILTYPE↑ DO
IF (FORM = SUBRANGE) AND
((VMIN.IVAL >= ORD(' ')) AND
(VMAX.IVAL <= ORD('←')))
THEN LSP↑.FILE←FORM := TEXT←FILE
END;
IF FILEPF AND (FILE←MODE = BINARY←MODE)
THEN FILEPF := FALSE
END;
IF LSP1 <> NIL
THEN
IF LSP1↑.FORM = FILES
THEN
BEGIN
ERROR(254); LSP↑.FILTYPE := NIL
END
END
END (*CASE*);
FSP := LSP; FBITSIZE := LBITSIZE
END;
IFERRSKIP(166,FSYS)
END
ELSE FSP := NIL;
IF FSP = NIL
THEN
BEGIN
FSIZE := 1;FBITSIZE := 0
END
ELSE FSIZE := FSP↑.SIZE
END (*TYP*) ;
PROCEDURE LABELDECLARATION;
VAR
LCP: CTP;
BEGIN
IF JUMPER < JUMP←MAX
THEN JUMPER := JUMPER + 1
ELSE ERROR(319);
CURRENT←JUMP := JUMPER;
JUMP←TABLE[JUMPER] := 0;
LOOP
IF SY = INTCONST
THEN
BEGIN
NEW(LCP,LABELS);
WITH LCP↑ DO
BEGIN
SCOPE := LEVEL; NAME := ID; IDTYPE := NIL; NEXT := LAST←LABEL;
GOTO←CHAIN := 0; LABEL←ADDRESS := 0; LAST←LABEL := LCP;
JUMP←INDEX := JUMPER; EXIT←JUMP := FALSE;
IF VAL.IVAL > LABMAX
THEN ERROR(265)
END;
ENTERID(LCP);
INSYMBOL
END
ELSE ERROR(255);
IFERRSKIP(166,FSYS + [COMMA,SEMICOLON])
EXIT IF SY <> COMMA;
INSYMBOL
END;
IF SY = SEMICOLON
THEN INSYMBOL
ELSE ERROR(156)
END (*LABELDECLARATION*) ;
PROCEDURE CONSTANTDECLARATION;
VAR
LCP: CTP; LSP: STP; LVALU: VALU;
BEGIN
SKIPIFERR([IDENT],209,FSYS);
WHILE SY = IDENT DO
BEGIN
NEW(LCP,KONST);
WITH LCP↑ DO
BEGIN
NAME := ID; IDTYPE := NIL; NEXT := NIL
END;
INSYMBOL;
IF (SY = RELOP) AND (OP = EQOP)
THEN INSYMBOL
ELSE ERROR(157);
CONSTANT(FSYS + [SEMICOLON],LSP,LVALU);
ENTERID(LCP);
LCP↑.IDTYPE := LSP; LCP↑.VALUES := LVALU;
IF SY = SEMICOLON
THEN
BEGIN
INSYMBOL;
IFERRSKIP(166,FSYS + [IDENT])
END
ELSE ERROR(156)
END
END (*CONSTANTDECLARATION*) ;
PROCEDURE TYPEDECLARATION;
VAR
LCP,LCP1,LCP2: CTP; LSP: STP; LSIZE: ADDRRANGE;
LBITSIZE: BITRANGE;
BEGIN
SKIPIFERR([IDENT],209,FSYS);
WHILE SY = IDENT DO
BEGIN
NEW(LCP,TYPES);
WITH LCP↑ DO
BEGIN
NAME := ID; NEXT := NIL
END;
INSYMBOL;
IF (SY = RELOP) AND (OP = EQOP)
THEN INSYMBOL
ELSE ERROR(157);
TYP(FSYS + [SEMICOLON],LSP,LSIZE,LBITSIZE);
ENTERID(LCP);
WITH LCP↑ DO
BEGIN
IDTYPE := LSP;
(* LOOK FOR UNSATISFIED POINTER FORWARD REFERENCES;
THERE MAY BE MORE THAN ONE FOR ONE TYPE-DECLARATION *)
LCP1 := FORWARD←POINTER←TYPE;
WHILE LCP1 <> NIL DO
BEGIN
IF LCP1↑.NAME = NAME
THEN
BEGIN
IF IDTYPE↑.FORM = FILES
THEN
BEGIN
ERROR(254);
LCP1↑.IDTYPE↑.ELTYPE := NIL
END
ELSE LCP1↑.IDTYPE↑.ELTYPE := IDTYPE;
IF LCP1 <> FORWARD←POINTER←TYPE
THEN LCP2↑.NEXT := LCP1↑.NEXT
ELSE FORWARD←POINTER←TYPE := LCP1↑.NEXT
END
ELSE LCP2 := LCP1;
LCP1 := LCP1↑.NEXT
END
END;
IF SY = SEMICOLON
THEN
BEGIN
INSYMBOL;
IFERRSKIP(166,FSYS + [IDENT])
END
ELSE ERROR(156)
END;
WHILE FORWARD←POINTER←TYPE <> NIL DO
BEGIN
ERROR←WITH←TEXT(405,FORWARD←POINTER←TYPE↑.NAME);
FORWARD←POINTER←TYPE := FORWARD←POINTER←TYPE↑.NEXT
END
END (*TYPEDECLARATION*) ;
PROCEDURE VARIABLEDECLARATION;
VAR
LCP,NXT: CTP; LSP: STP; LSIZE: ADDRRANGE;
LBITSIZE: BITRANGE; LPARMPTR: PTP; FOUND: BOOLEAN;
LFILEPTR: FTP;
BEGIN
NXT := NIL;
REPEAT
LOOP
IF SY = IDENT
THEN
BEGIN
NEW(LCP,VARS);
WITH LCP↑ DO
BEGIN
NAME := ID; NEXT := NXT;
IDTYPE := NIL; VKIND := ACTUAL; VLEV := LEVEL
END;
ENTERID(LCP);
NXT := LCP;
INSYMBOL
END
ELSE ERROR(209);
SKIPIFERR(FSYS + [COMMA,COLON] + TYPEDELS,166,[SEMICOLON])
EXIT IF SY <> COMMA;
INSYMBOL
END;
IF SY = COLON
THEN INSYMBOL
ELSE ERROR(151);
TYP(FSYS + [SEMICOLON] + TYPEDELS,LSP,LSIZE,LBITSIZE);
IF NOT TESTPACKED AND (LSP <> NIL)
THEN
BEGIN
IF LSP↑.FORM = ARRAYS
THEN TESTPACKED := LSP↑.ARRAYPF;
IF LSP↑.FORM = RECORDS
THEN TESTPACKED := LSP↑.RECORDPF
END;
WHILE NXT <> NIL DO
WITH NXT↑ DO
BEGIN
IDTYPE := LSP; VADDR := LC;
LC := LC + LSIZE ;
IF LSP <> NIL
THEN
IF LSP↑.FORM = FILES
THEN
IF LEVEL > 1
THEN ERROR(454)
ELSE
BEGIN
IF START←CHANNEL = 0
THEN CHANNEL := FILEPTR↑.FILEIDENT↑.CHANNEL
ELSE
BEGIN
CHANNEL := START←CHANNEL;
START←CHANNEL := 0
END;
IF CHANNEL < MAX←CHANNEL
THEN CHANNEL := CHANNEL + 1
ELSE ERROR(354);
NEW(LFILEPTR);
WITH LFILEPTR↑ DO
BEGIN
NEXTFTP := FILEPTR ;
FILEIDENT := NXT
END ;
FILEPTR := LFILEPTR;
LPARMPTR := PARMPTR; FOUND := FALSE;
WHILE LPARMPTR <> NIL DO
WITH LPARMPTR↑ DO
BEGIN
IF FILEID = NAME
THEN
IF FOUND
THEN ERROR(466)
ELSE
BEGIN
FILEIDPTR := NXT; FOUND := TRUE
END;
LPARMPTR := NEXTPTP
END
END (*ELSE*) ;
NXT := NEXT
END;
IF SY = SEMICOLON
THEN
BEGIN
INSYMBOL;
IFERRSKIP(166,FSYS + [IDENT])
END
ELSE ERROR(156)
UNTIL NOT (SY IN TYPEDELS + [IDENT]);
WHILE FORWARD←POINTER←TYPE <> NIL DO
BEGIN
ERROR←WITH←TEXT(405,FORWARD←POINTER←TYPE↑.NAME);
FORWARD←POINTER←TYPE := FORWARD←POINTER←TYPE↑.NEXT
END
END (*VARIABLEDECLARATION*) ;
PROCEDURE PROCEDUREDECLARATION(PROCFLAG: BOOLEAN);
VAR
OLDLEV: 0..MAXLEVEL; LCP,LCP1: CTP; LSP: STP;
FORW: BOOLEAN; OLDTOP: DISPRANGE; LNXT: CTP;
LLC,LCM: ADDRRANGE;
PROCEDURE PARAMETERLIST(FSYS:SETOFSYS; VAR FIP : CTP);
VAR
LIP,LIP1,LIP2,LIP3,LIP4 : CTP; LSP : STP;
LKIND : IDKIND; LPARS:ADDRRANGE; FUNCDECL : BOOLEAN;
PROCEDURE FFPARLIST ( FSYS : SETOFSYS; VAR FIP : CTP; VAR FPARLC : ADDRRANGE);
VAR
LIP,LIP1,LIP2,LIP3 : CTP; LSP : STP;
LKIND : IDKIND; LPARS : ADDRRANGE; FUNCDECL : BOOLEAN;
BEGIN (*FFPARLIST*)
FIP:=NIL;
SKIPIFERR(FSYS+[LPARENT],256,[]);
IF SY=LPARENT
THEN
BEGIN
INSYMBOL;
SKIPIFERR([IDENT,VARSY,PROCEDURESY,FUNCTIONSY],256,FSYS+[RPARENT]);
IF SY IN [IDENT ,VARSY,PROCEDURESY,FUNCTIONSY]
THEN
LOOP
IF SY IN [PROCEDURESY, FUNCTIONSY]
THEN
BEGIN
FUNCDECL:= SY=FUNCTIONSY;
INSYMBOL;
IF FUNCDECL
THEN NEW(LIP,FUNC,DECLARED,FORMAL)
ELSE
NEW(LIP,PROC,DECLARED,FORMAL);
WITH LIP↑ DO
BEGIN
IDTYPE:=NIL; NEXT:=NIL; PFLEV:=LEVEL;
PFADDR:=FPARLC; FPARLC:=FPARLC+1;
LPARS:=1+ORD(FUNCDECL);
IF FUNCDECL
THEN FFPARLIST(FSYS+[RPARENT,COLON,SEMICOLON],LIP3,LPARS)
ELSE
FFPARLIST(FSYS+[RPARENT,SEMICOLON],LIP3,LPARS);
FPARAM:=LIP3; PARLISTSIZE:=LPARS;
END;
IF FUNCDECL
THEN
IF SY=COLON
THEN
BEGIN
INSYMBOL;
IF SY<>IDENT
THEN ERROR(209)
ELSE
BEGIN
SEARCHID([TYPES],LIP2);
LSP:=LIP2↑.IDTYPE;
IF LSP<> NIL
THEN
IF NOT(LSP↑.FORM IN [SCALAR,SUBRANGE,POINTER])
THEN
BEGIN
ERROR(551);
LSP:=NIL
END;
LIP↑.IDTYPE:=LSP
END
END
ELSE ERROR(151)
END (*SY IN [FUNCTIONSY,PROCEDURESY]*)
ELSE
BEGIN
IF SY=VARSY
THEN
BEGIN
INSYMBOL;
LKIND:=FORMAL;
IF SY=COLON
THEN INSYMBOL
ELSE ERROR(151)
END
ELSE LKIND:=ACTUAL;
IF SY=IDENT
THEN
BEGIN
SEARCHID([TYPES],LIP2);
INSYMBOL;
LSP:=LIP2↑.IDTYPE;
IF LSP<>NIL
THEN
IF LKIND=ACTUAL
THEN
IF LSP↑.FORM=FILES
THEN
BEGIN
ERROR(355); LSP:=NIL
END;
NEW(LIP,VARS);
WITH LIP↑ DO
BEGIN
IDTYPE:=LSP; NEXT:=NIL; VKIND:=LKIND; VLEV:=LEVEL;
VADDR:=FPARLC;
IF LKIND=FORMAL
THEN FPARLC:=FPARLC+1
ELSE
IF LSP<>NIL
THEN FPARLC:=FPARLC+LSP↑.SIZE;
END
END
ELSE
BEGIN
ERROR(209); LIP:=NIL
END
END;
IF LIP<>NIL
THEN
BEGIN
IF FIP=NIL
THEN FIP:=LIP
ELSE LIP1↑.NEXT:=LIP;
LIP1:=LIP
END;
SKIPIFERR([SEMICOLON,IDENT,VARSY,PROCEDURESY,FUNCTIONSY,RPARENT],256,FSYS);
EXIT IF NOT(SY IN [SEMICOLON,IDENT,VARSY,PROCEDURESY,FUNCTIONSY]);
IF SY=SEMICOLON
THEN INSYMBOL
ELSE ERROR(156)
END (*LOOP*);
IF SY=RPARENT
THEN INSYMBOL
ELSE ERROR(152);
SKIPIFERR(FSYS,166,[])
END
END (*FFPARLIST*);
BEGIN (*PARAMETERLIST*)
FIP:=NIL; LIP1:=NIL;
SKIPIFERR(FSYS+[LPARENT],256,[]);
IF SY=LPARENT
THEN
BEGIN
IF FORW
THEN ERROR(553);
INSYMBOL;
SKIPIFERR([PROCEDURESY,FUNCTIONSY,VARSY,IDENT],256,FSYS+[RPARENT]);
IF SY IN [PROCEDURESY,FUNCTIONSY,VARSY,IDENT]
THEN
LOOP
LIP2:=NIL;
IF SY IN [PROCEDURESY,FUNCTIONSY]
THEN
BEGIN
FUNCDECL:= SY=FUNCTIONSY;
INSYMBOL;
LOOP
IF SY=IDENT
THEN
BEGIN
IF FUNCDECL
THEN
NEW(LIP,FUNC,DECLARED,FORMAL)
ELSE
NEW(LIP,PROC,DECLARED,FORMAL);
WITH LIP↑ DO
BEGIN
NAME:=ID; NEXT:=NIL; PFLEV:=LEVEL;IDTYPE:=NIL;
PFADDR:=LC; LC:=LC+1; HIGHEST←REGISTER:=PARREGCMAX
END;
ENTERID(LIP);
INSYMBOL;
IF FIP=NIL
THEN FIP:=LIP
ELSE LIP1↑.NEXT:=LIP;
LIP1:=LIP;
IF LIP2=NIL
THEN LIP2:=LIP;
END
ELSE ERRANDSKIP(209,FSYS+[LPARENT,COLON,COMMA,IDENT,SEMICOLON,RPARENT]);
EXIT IF NOT (SY IN [COMMA,IDENT]);
IF SY=COMMA
THEN INSYMBOL
ELSE ERROR(158)
END (*LOOP*);
IF FUNCDECL
THEN
BEGIN
LPARS:=2;
FFPARLIST(FSYS+[COLON,SEMICOLON,RPARENT],LIP3,LPARS);
LSP:=NIL;
IF SY=COLON
THEN
BEGIN
INSYMBOL;
IF SY=IDENT
THEN
BEGIN
SEARCHID([TYPES],LIP4);
LSP:=LIP4↑.IDTYPE;
IF LSP<>NIL
THEN
IF NOT(LSP↑.FORM IN [SCALAR,SUBRANGE,POINTER])
THEN
BEGIN
ERROR(551); LSP:=NIL
END;
INSYMBOL
END
ELSE ERRANDSKIP(209,FSYS+[COLON,COMMA,IDENT])
END
ELSE ERROR(151);
WHILE LIP2<>NIL DO WITH LIP2↑ DO
BEGIN
IDTYPE:=LSP;
FPARAM:=LIP3; PARLISTSIZE:=LPARS;
LIP2:=NEXT
END
END
ELSE
BEGIN
LPARS:=1;
FFPARLIST(FSYS+[SEMICOLON,RPARENT],LIP3,LPARS);
WHILE LIP2<>NIL DO WITH LIP2↑ DO
BEGIN
FPARAM:=LIP3;
PARLISTSIZE:=LPARS;
LIP2:=NEXT
END
END
END (*SY IN [PROCEDURESY,FUNCTIONSY]*)
ELSE
BEGIN
IF SY=VARSY
THEN
BEGIN
LKIND:=FORMAL; INSYMBOL
END
ELSE LKIND:=ACTUAL;
LOOP
IF SY=IDENT
THEN
BEGIN
NEW(LIP,VARS);
WITH LIP↑ DO
BEGIN
NAME:=ID; NEXT:=NIL; VKIND:=LKIND; VLEV:=LEVEL;
END;
ENTERID(LIP);
INSYMBOL;
IF FIP=NIL
THEN FIP:=LIP
ELSE LIP1↑.NEXT:=LIP;
LIP1:=LIP;
IF LIP2=NIL
THEN LIP2:=LIP
END
ELSE ERRANDSKIP(209,FSYS+[COLON,COMMA,IDENT]);
EXIT IF NOT(SY IN [COMMA,IDENT]);
IF SY=COMMA
THEN INSYMBOL
ELSE ERROR(158)
END (*LOOP*);
IF SY=COLON
THEN
BEGIN
INSYMBOL;
IF SY=IDENT
THEN
BEGIN
SEARCHID([TYPES],LIP3);
INSYMBOL;
LSP:=LIP3↑.IDTYPE;
IF LSP<>NIL
THEN
IF (LKIND=ACTUAL) AND(LSP↑.FORM=FILES)
THEN
BEGIN
ERROR(355); LSP:=NIL
END
END
ELSE
ERROR(209)
END
ELSE ERROR(151);
WHILE LIP2<>NIL DO WITH LIP2↑ DO
BEGIN
VADDR:=LC;
IF LSP<>NIL
THEN
IF VKIND=FORMAL
THEN LC:=LC+1
ELSE LC:=LC+LSP↑.SIZE;
IDTYPE:=LSP;
LIP2:=NEXT
END;
END (*SY<>FUNCTIONSY*);
SKIPIFERR([RPARENT,SEMICOLON],256,[PROCEDURESY,FUNCTIONSY,IDENT,VARSY]+FSYS)
EXIT IF NOT(SY IN [SEMICOLON,PROCEDURESY,FUNCTIONSY,VARSY,IDENT]);
IF SY=SEMICOLON
THEN INSYMBOL
ELSE ERROR(156)
END (*LOOP*);
IF SY=RPARENT
THEN INSYMBOL
ELSE ERROR(152);
SKIPIFERR(FSYS,166,[])
END (*SY=LPARENT*)
END (*PARAMETERLIST*);
BEGIN
(*PROCEDUREDECLARATION*)
FSYS:=FSYS-[INITPROCSY];
LLC := LC;
IF PROCFLAG
THEN LC := 1
ELSE LC := 2;
IF SY = IDENT
THEN
BEGIN
SEARCHSECTION(DISPLAY[TOP].FNAME,LCP); (*DECIDE WHETHER FORW.*)
IF LCP <> NIL
THEN
WITH LCP↑ DO
BEGIN
IF KLASS = PROC
THEN
IF PFKIND=ACTUAL
THEN FORW:=FORWDECL AND PROCFLAG
ELSE FORW:=FALSE
ELSE
IF KLASS = FUNC
THEN
IF PFKIND=ACTUAL
THEN FORW:=FORWDECL AND NOT PROCFLAG
ELSE FORW:=FALSE
ELSE FORW := FALSE;
IF NOT FORW
THEN ERROR(406)
END
ELSE FORW := FALSE;
IF NOT FORW
THEN
BEGIN
IF PROCFLAG
THEN NEW(LCP,PROC,DECLARED,ACTUAL)
ELSE NEW(LCP,FUNC,DECLARED,ACTUAL);
WITH LCP↑ DO
BEGIN
NAME := ID; IDTYPE := NIL; TESTFWDPTR := NIL; HIGHEST←REGISTER := PARREGCMAX;
FORWDECL := FALSE; EXTERNDECL := FALSE; LANGUAGE := PASCALSY; PARLISTSIZE:=0;
PFLEV := LEVEL; PFADDR := 0; FOR I := 0 TO MAXLEVEL DO LINKCHAIN[I] := 0
END;
ENTERID(LCP)
END
ELSE LC:=LCP↑.PARLISTSIZE;
INSYMBOL
END
ELSE
BEGIN
ERROR(209);
IF PROCFLAG
THEN LCP := UPRCPTR
ELSE LCP := UFCTPTR
END;
OLDLEV := LEVEL; OLDTOP := TOP;
IF LEVEL < MAXLEVEL
THEN LEVEL := LEVEL + 1
ELSE ERROR(453);
IF TOP < DISPLIMIT
THEN
BEGIN
TOP := TOP + 1;
WITH DISPLAY[TOP] DO
BEGIN
FNAME := NIL; OCCUR := BLCK;
IF DEBUG
THEN
BEGIN
NEW(LCP1); LCP1↑ := UPRCPTR↑;
LCP1↑.NEXT := LCP;
ENTERID(LCP1);
IF FORW AND (LCP↑.NEXT <> NIL)
THEN
BEGIN
LCP1↑.LLINK := LCP↑.NEXT; LCP1↑.RLINK := LCP↑.NEXT;
LCP↑.NEXT↑.SELFCTP := NIL
END
END
ELSE
IF FORW
THEN FNAME := LCP↑.NEXT
END (*WITH DISPLAY[TOP]*)
END
ELSE ERROR(404);
IF PROCFLAG
THEN
BEGIN
PARAMETERLIST([SEMICOLON],LCP1);
IF NOT FORW
THEN WITH LCP↑ DO
BEGIN
NEXT:=LCP1; PARLISTSIZE:=LC
END
END
ELSE
BEGIN
PARAMETERLIST([SEMICOLON,COLON],LCP1);
IF NOT FORW
THEN WITH LCP↑ DO
BEGIN
NEXT := LCP1; PARLISTSIZE:=LC
END;
IF SY = COLON
THEN
BEGIN
INSYMBOL;
IF SY = IDENT
THEN
BEGIN
IF FORW
THEN ERROR(552);
SEARCHID([TYPES],LCP1);
LSP := LCP1↑.IDTYPE;
LCP↑.IDTYPE := LSP;
IF LSP <> NIL
THEN
IF NOT (LSP↑.FORM IN [SCALAR,SUBRANGE,POINTER])
THEN
BEGIN
ERROR(551); LCP↑.IDTYPE := NIL
END;
INSYMBOL
END
ELSE ERRANDSKIP(209,FSYS + [SEMICOLON])
END
ELSE
IF NOT FORW
THEN ERROR(455)
END;
IF SY = SEMICOLON
THEN INSYMBOL
ELSE ERROR(156);
IF SY = FORWARDSY
THEN
BEGIN
IF FORW
THEN ERROR(257)
ELSE
WITH LCP↑ DO
BEGIN
TESTFWDPTR := FORWARD←PROCEDURES; FORWARD←PROCEDURES := LCP; FORWDECL := TRUE;
IF NEXT <> NIL
THEN NEXT↑.SELFCTP := UVARPTR
END;
INSYMBOL;
IF SY = SEMICOLON
THEN INSYMBOL
ELSE ERROR(156);
IFERRSKIP(166,FSYS)
END (* SY = FORWARDSY *)
ELSE
WITH LCP↑ DO
BEGIN
IF SY IN (LANGUAGESYS + [EXTERNSY])
THEN
BEGIN
IF FORW
THEN ERROR(257)
ELSE EXTERNDECL := TRUE;
TTYREAD := TRUE;
IF LEVEL <> 2
THEN ERROR(464);
IF SY IN LANGUAGESYS
THEN LANGUAGE := SY;
INSYMBOL;
IF (LIBRARY←INDEX = 0) OR (NOT LIBRARY[LANGUAGE].CHAINED)
THEN
BEGIN
LIBRARY←INDEX:= LIBRARY←INDEX+1;
LIBRARY←ORDER[LIBRARY←INDEX]:= LANGUAGE;
LIBRARY[LANGUAGE].CHAINED:= TRUE
END;
PFLEV := 1; PFCHAIN := EXTERNPFPTR; EXTERNPFPTR := LCP;
IF SY = SEMICOLON
THEN INSYMBOL
ELSE ERROR(156);
IFERRSKIP(166,FSYS)
END (* SY = EXTERNSY *)
ELSE
BEGIN
PFCHAIN := LOCALPFPTR;
LOCALPFPTR := LCP;
FORWDECL := FALSE;
ACTIVATED := TRUE;
BLOCK(LCP,FSYS,[BEGINSY,FUNCTIONSY,PROCEDURESY,PERIOD,SEMICOLON]);
ACTIVATED := FALSE;
IF SY = SEMICOLON
THEN
BEGIN
INSYMBOL;
SKIPIFERR([BEGINSY,PROCEDURESY,FUNCTIONSY],166,FSYS)
END
ELSE ERROR(156)
END (* SY <> EXTERNSY *)
END (* SY <> FORWARDSY *) ;
LEVEL := OLDLEV; TOP := OLDTOP; LC := LLC
END (*PROCEDUREDECLARATION*) ;
PROCEDURE BODY(FSYS: SETOFSYS);
CONST
FILEOF = 1B; FILEOL = 2B; FILOPN = 3B; FILSTA = 11B; FILDEV = 12B;
FILBHP = 13B; FILNAM = 14B; FILBFH = 20B; FILLNR = 23B; FILCMP = 25B;
VAR
LAST←FILE: CTP;
REG2←SAVED: BOOLEAN;
REG2←LOCATION: ADDRRANGE;
PROCEDURE GENERATE←WORD(FRELBYTE: RELBYTE; FLEFTH: ADDRRANGE; FRIGHTH: ADDRRANGE);
BEGIN
(*GENERATE←WORD*)
CIX := CIX + 1;
IF CIX > CODE←SIZE
THEN
BEGIN
IF NOT OVERRUN
THEN
BEGIN
OVERRUN := TRUE;
IF FPROCP = NIL
THEN ERROR←WITH←TEXT(356,'MAIN ')
ELSE ERROR←WITH←TEXT(356,FPROCP↑.NAME)
END;
CIX := 0
END;
WITH CODE←ARRAY↑.HALFWORD[CIX] DO
BEGIN
LEFTHALF := FLEFTH;
RIGHTHALF := FRIGHTH
END;
CODE←REFERENCE↑[CIX] := NOINSTR; CODE←RELOCATION↑[CIX] := FRELBYTE;
IC := IC + 1
END (*GENERATE←WORD*) ;
PROCEDURE INSERT←ADDRESS(FRELBYTE: RELBYTE; FCIX:CODERANGE; FIC:ADDRRANGE);
BEGIN
CODE←ARRAY↑.INSTRUCTION[FCIX].ADDRESS := FIC;
CODE←RELOCATION↑[FCIX] := FRELBYTE
END;
PROCEDURE INCREMENT←REGC;
BEGIN
REGC := REGC + 1 ;
IF REGC > REGCMAX
THEN
BEGIN
ERROR(310) ; REGC := REGIN
END
END ;
PROCEDURE DEPOSIT←CONSTANT(KONSTTYP:CSTCLASS; FATTR:ATTR);
VAR
II:INTEGER;
LKSP,LLKSP: KSP;
LCSP: CSP;
LREF: CODEREFS;
NEWCONSTANT,EXISTANT:BOOLEAN;
LCIX: CODERANGE;
BEGIN
NEWCONSTANT:=TRUE; LKSP := FIRSTKONST;
WHILE (LKSP <> NIL) AND NEWCONSTANT DO
WITH LKSP↑,CONSTPTR↑ DO
BEGIN
IF CCLASS = KONSTTYP
THEN
CASE KONSTTYP OF
REEL:
NEWCONSTANT := RVAL <> FATTR.CVAL.VALP↑.RVAL;
INT:
NEWCONSTANT := INTVAL <> FATTR.CVAL.IVAL;
PSET:
NEWCONSTANT := PVAL <> FATTR.CVAL.VALP↑.PVAL;
BPTR:
NEWCONSTANT := BYTE <> FATTR.CVAL.BYTE;
STRD,
STRG:
IF FATTR.CVAL.VALP↑.SLGTH = SLGTH
THEN
BEGIN
EXISTANT := TRUE;
II := 1;
REPEAT
IF FATTR.CVAL.VALP↑.SVAL[II] <> SVAL[II]
THEN EXISTANT := FALSE;
II:=II+1
UNTIL (II>SLGTH) OR NOT EXISTANT;
IF EXISTANT
THEN NEWCONSTANT := FALSE
END
END (*CASE*);
LLKSP := LKSP; LKSP := NEXTKONST
END (*WHILE*);
IF KONSTTYP = BPTR
THEN LREF := POINTREF
ELSE LREF := CONSTREF;
IF NOT NEWCONSTANT
THEN
WITH LLKSP↑ DO
BEGIN
INSERT←ADDRESS(RIGHT,CIX,ADDR); CODE←REFERENCE↑[CIX]:= LREF;
IF KONSTTYP IN [PSET,STRD]
THEN
BEGIN
INSERT←ADDRESS(RIGHT,CIX-1,ADDR-1); CODE←REFERENCE↑[CIX-1]:= LREF
END;
ADDR:= IC-1
END
ELSE
BEGIN
IF KONSTTYP = INT
THEN
BEGIN
NEW(LCSP,INT); LCSP↑.INTVAL := FATTR.CVAL.IVAL
END
ELSE
IF KONSTTYP = BPTR
THEN
BEGIN
NEW(LCSP,BPTR); LCSP↑.BYTE := FATTR.CVAL.BYTE
END
ELSE LCSP := FATTR.CVAL.VALP;
CODE←REFERENCE↑[CIX] := LREF;
IF KONSTTYP IN [PSET,STRD]
THEN CODE←REFERENCE↑[CIX-1] := LREF;
NEW(LKSP);
WITH LKSP↑ DO
BEGIN
ADDR := IC-1; DOUBLE←CHAIN := KONSTTYP IN [PSET,STRD];
CONSTPTR := LCSP; NEXTKONST := NIL
END;
IF FIRSTKONST = NIL
THEN FIRSTKONST := LKSP
ELSE LLKSP↑.NEXTKONST := LKSP
END
END (*DEPOSIT←CONSTANT*);
PROCEDURE MACRO(FRELBYTE : RELBYTE;
FINSTR : INSTRANGE;
FAC : ACRANGE;
FINDBIT : IBRANGE;
FINXREG : ACRANGE;
FADDRESS : ADDRRANGE);
BEGIN
IF NOT INITGLOBALS
THEN
BEGIN
CIX := CIX + 1;
IF CIX > CODE←SIZE
THEN
BEGIN
IF NOT OVERRUN
THEN
BEGIN
OVERRUN := TRUE;
IF FPROCP = NIL
THEN ERROR←WITH←TEXT(356,'MAIN ')
ELSE ERROR←WITH←TEXT(356, FPROCP↑.NAME)
END;
CIX := 0
END;
WITH CODE←ARRAY↑.INSTRUCTION[CIX] DO
BEGIN
INSTR :=FINSTR;
AC :=FAC;
INDBIT :=FINDBIT;
INXREG :=FINXREG;
ADDRESS :=FADDRESS;
CODE←REFERENCE↑[CIX]:= NOREF; CODE←RELOCATION↑[CIX] := FRELBYTE
END;
IC := IC + 1
END
ELSE ERROR(507)
END (*MACRO*);
PROCEDURE MACRO5(FRELBYTE: RELBYTE; FINSTR : INSTRANGE; FAC,FINXREG : ACRANGE; FADDRESS : ADDRRANGE);
BEGIN
MACRO(FRELBYTE,FINSTR,FAC,0,FINXREG,FADDRESS)
END;
PROCEDURE MACRO4(FINSTR: INSTRANGE;FAC, FINXREG: ACRANGE;FADDRESS: ADDRRANGE);
BEGIN
MACRO(NO,FINSTR,FAC,0,FINXREG,FADDRESS)
END;
PROCEDURE MACRO3(FINSTR : INSTRANGE; FAC:ACRANGE; FADDRESS: ADDRRANGE);
BEGIN
MACRO(NO,FINSTR,FAC,0,0,FADDRESS)
END;
PROCEDURE MACRO4R(FINSTR : INSTRANGE; FAC,FINXREG : ACRANGE; FADDRESS : ADDRRANGE);
BEGIN
MACRO(RIGHT,FINSTR,FAC,0,FINXREG,FADDRESS)
END;
PROCEDURE MACRO3R(FINSTR : INSTRANGE; FAC:ACRANGE; FADDRESS: ADDRRANGE);
BEGIN
MACRO(RIGHT,FINSTR,FAC,0,0,FADDRESS)
END;
PROCEDURE MACRO2(FINSTR: INSTRANGE; FAC: ACRANGE);
BEGIN
MACRO(NO,FINSTR,FAC,0,0,0)
END;
PROCEDURE PUT←PAGENUMBER;
VAR
LRELBYTE: RELBYTE;
BEGIN
LRELBYTE := RIGHT;
WITH PAGER DO
BEGIN
LASTPAGER := IC;
WITH WORD1 DO
BEGIN
IF (ADDRESS = 0) OR (ADDRESS = 377777B)
THEN LRELBYTE := NO;
MACRO5(LRELBYTE,304B(*CAIA*),AC,INXREG,ADDRESS)
END;
IF (RHALF = 0) OR (RHALF = 377777B)
THEN GENERATE←WORD(NO,LHALF,RHALF)
ELSE GENERATE←WORD(RIGHT,LHALF,RHALF);
LASTPAGE := PAGECNT
END
END;
PROCEDURE PUT←LINENUMBER;
VAR
LRELBYTE: RELBYTE;
BEGIN
LRELBYTE := RIGHT;
IF PAGECNT <> LASTPAGE
THEN PUT←PAGENUMBER;
IF LINECNT <> LASTLINE
THEN (*BREAKPOINT*)
BEGIN
IF LINENR <> '-----'
THEN
BEGIN
LINECNT := 0;
FOR I := 1 TO 5 DO LINECNT := 10*LINECNT + ORD(LINENR[I]) - ORD('0')
END;
LINEDIFF := LINECNT - LASTLINE;
IF (LASTSTOP = 0) OR (LASTSTOP = 377777B)
THEN LRELBYTE := NO;
IF LINEDIFF > 255
THEN
BEGIN
MACRO5(LRELBYTE,334B(*SKIPA*),0,0,LASTSTOP);
LASTSTOP := IC-1;
MACRO3(320B(*JUMP*),0,LASTLINE)
END
ELSE
BEGIN
MACRO5(LRELBYTE,320B(*JUMP*),LINEDIFF MOD 16,LINEDIFF DIV 16,LASTSTOP); (*NOOP*)
LASTSTOP := IC - 1
END;
LASTLINE := LINECNT
END
END;
PROCEDURE SUPPORT(FSUPPORT: SUPPORTS);
BEGIN
IF FSUPPORT = FORTRANRESET
THEN MACRO3R(265B(*JSP*),BASIS,RUNTIME←SUPPORT.LINK[FORTRANRESET])
ELSE
IF FSUPPORT = EXITPROGRAM
THEN MACRO3R(254B(*JRST*),0,RUNTIME←SUPPORT.LINK[EXITPROGRAM])
ELSE MACRO3R(260B(*PUSHJ*),TOPP,RUNTIME←SUPPORT.LINK[FSUPPORT]);
CODE←REFERENCE↑[CIX]:= EXTERNREF;
RUNTIME←SUPPORT.LINK[FSUPPORT]:= IC-1
END;
PROCEDURE CLOSE←FILES;
VAR
LFILEPTR: FTP;
BEGIN
LFILEPTR := FILEPTR;
WHILE LFILEPTR <> NIL DO
WITH LFILEPTR↑, FILEIDENT↑ DO
BEGIN
MACRO3R(551B(*HRRZI*),REGIN+1,VADDR);
SUPPORT(CLOSEFILE);
LFILEPTR := NEXTFTP
END
END;
PROCEDURE ENTERBODY;
VAR
I: INTEGER; LCP : CTP;
LBTP: BTP;
BEGIN
LBTP := LASTBTP;
WHILE LBTP <> NIL DO
BEGIN
WITH LBTP↑, ARRAYBPS[BITSIZE] DO
IF STATE = REQUESTED
THEN
BEGIN
ARRAYSP↑.ARRAYBPADDR := IC;
ADDRESS := IC; STATE := CALCULATED;
IC := IC + BYTEMAX
END
ELSE ARRAYSP↑.ARRAYBPADDR := ADDRESS;
LBTP := LBTP↑.LAST
END;
IF FPROCP <> NIL
THEN
BEGIN
GENERATE←WORD(NO,0,377777B); IDTREE := CIX; (*IF DEBUG, INSERT TREE POINTER HERE*)
WITH FPROCP↑ DO
IF PFLEV > 1
THEN FOR I := MAXLEVEL DOWNTO PFLEV+1 DO
MACRO4(540B(*HRR*),BASIS,BASIS,-1);
PFSTART := IC;
IF FPROCP↑.PFLEV = 1
THEN MACRO4(512B(*HLLZM*),BASIS,TOPP,-1)
ELSE MACRO4(202B(*MOVEM*),BASIS,TOPP,-1);
MACRO3(507B(*HRLS*),BASIS,TOPP);
MACRO4(307B(*CAIG*),NEWREG,TOPP,0); STACKSIZE1 := CIX;
SUPPORT(STACKOVERFLOW);
MACRO4(541B(*HRRI*),TOPP,TOPP,0); STACKSIZE2 := CIX;
IF TESTPACKED
THEN
IF LC-LCPAR <= 4
THEN FOR I := LCPAR TO LC-1 DO MACRO4(402B(*SETZM*),0,BASIS,I)
ELSE
BEGIN
MACRO4(551B(*HRRZI*),REG1,BASIS,LCPAR);
MACRO3(505B(*HRLI*),REG1,LCPAR-LC);
MACRO4(402B(*SETZM*),0,REG1,0);
MACRO3R(253B(*AOBJN*),REG1,IC-1)
END;
REGC := REGIN+1;
LCP := FPROCP↑.NEXT;
WHILE LCP <> NIL DO
WITH LCP↑ DO
BEGIN
IF KLASS <> VARS
THEN
BEGIN
IF REGC <= FPROCP↑.HIGHEST←REGISTER
THEN
BEGIN
MACRO4(202B(*MOVEM*),REGC,BASIS,PFADDR);
INCREMENT←REGC
END
END
ELSE
IF IDTYPE <> NIL
THEN
IF (VKIND=FORMAL) OR (IDTYPE↑.SIZE=1)
THEN (*COPY PARAMETERS FROM REGISTERS INTO LOCAL CELLS*)
BEGIN
IF REGC <= FPROCP↑.HIGHEST←REGISTER
THEN
BEGIN
MACRO4(202B(*MOVEM*),REGC,BASIS,VADDR); REGC := REGC + 1
END
END
ELSE
IF IDTYPE↑.SIZE=2
THEN
BEGIN
IF REGC <= FPROCP↑.HIGHEST←REGISTER
THEN
BEGIN
MACRO4(202B(*MOVEM*),REGC,BASIS,VADDR);
IF REGC<FPROCP↑.HIGHEST←REGISTER
THEN MACRO4(202B(*MOVEM*),REGC+1,BASIS,VADDR+1)
END;
REGC:=REGC+2
END
ELSE
BEGIN
IF REGC <= FPROCP↑.HIGHEST←REGISTER
THEN (*COPY MULTIPLE VALUES INTO LOCAL CELLS*)
BEGIN
MACRO3(514B(*HRLZ*),REG1,REGC); REGC := REGC + 1
END
ELSE MACRO4(514B(*HRLZ*),REG1,BASIS,VADDR);
MACRO4(541B(*HRRI*),REG1,BASIS,VADDR);
MACRO4(251B(*BLT*),REG1,BASIS,VADDR+IDTYPE↑.SIZE-1)
END;
LCP := LCP↑.NEXT
END
END
ELSE MAIN←START := IC;
IF (CURRENT←JUMP <> 0) AND (NOT EXTERNAL OR (LEVEL > 1))
THEN
BEGIN
JUMP←TABLE[CURRENT←JUMP] := IC;
MACRO2(202B(*MOVEM*),BASIS); CODE←REFERENCE↑[CIX] := SAVEREF;
MACRO2(202B(*MOVEM*),TOPP); CODE←REFERENCE↑[CIX] := SAVEREF
END
END (*ENTERBODY*);
PROCEDURE LEAVEBODY;
VAR
LCP: CTP; I: INTEGER;
LKSP: KSP ; LPARMPTR: PTP;
LDECLSCALPTR: STP;
ICCHANGE: PACKED RECORD
CASE BOOLEAN OF
FALSE:(ICVAL: ADDRRANGE);
TRUE :(ICCSP: CSP)
END;
PROCEDURE ALFACONSTANT( FSTRING: ALFA);
VAR
LCSP: CSP;
BEGIN
NEW(LCSP,STRG);
WITH LCSP↑ DO
BEGIN
SLGTH := 10; FOR I := 1 TO 10 DO SVAL[I] := FSTRING[I]
END;
WITH GATTR DO
BEGIN
TYPTR := ALFAPTR;
KIND := CST; CVAL.VALP := LCSP
END
END;
BEGIN
(*LEAVEBODY*)
IF DEBUG
THEN PUT←LINENUMBER;
IF FPROCP <> NIL
THEN
BEGIN
MACRO4(541B(*HRRI*),TOPP,BASIS,0);
MACRO4(547B(*HLRS*),BASIS,TOPP,-1);
MACRO3(263B(*POPJ*),TOPP,0)
END
ELSE
BEGIN
IF NOT EXTERNAL
THEN
BEGIN
CLOSE←FILES;
IF LIBRARY[FORTRANSY].CALLED AND FORTRAN←ENVIROMENT
THEN
BEGIN
MACRO3R(551B(*HRRZI*),REGIN + 1,STDFILEPTR[4]↑.VADDR);
SUPPORT(PUTBUFFER);
MACRO3(551B(*HRRZI*),BASIS,IC+3);
SUPPORT(FORTRANEXIT);
GENERATE←WORD(NO,0,0);
GENERATE←WORD(NO,0,0)
END
ELSE SUPPORT(EXITPROGRAM);
START←ADDRESS := IC;
MACRO3(255B(*JFCL*),0,RUNCORE*1024);
MACRO3(554B(*HLRZ*),BASIS,JBSA);
MACRO4(505B(*HRLI*),BASIS,BASIS,0);
MACRO4(541B(*HRRI*),TOPP,BASIS,0);
STACKSIZE1 := CIX; STACKSIZE2 := CIX;
MACRO3R(550B(*HRRZ*),REG1,START←ADDRESS);
MACRO3(317B(*CAMG*),REG1,JBREL);
MACRO3R(254B(*JRST*),0,IC+3);
MACRO3(047B,REG1,11B(*CORE-UUO*));
SUPPORT(NOCOREAVAILABLE);
MACRO3(200B(*MOVE*),NEWREG,JBREL);
MACRO4(307B(*CAIG*),NEWREG,TOPP,40B);
SUPPORT(STACKOVERFLOW);
MACRO3(506B(*HRLM*),NEWREG,JBSA);
MACRO3(275B(*SUBI*),NEWREG,1);
MACRO3(505B(*HRLI*),TOPP,400000B);
MACRO3(047B,REG0,0(*RESET-UUO*));
IF LIBRARY[FORTRANSY].CALLED AND FORTRAN←ENVIROMENT
THEN
BEGIN
MACRO4(202B(*MOVEM*),NEWREG,NEWREG,0);
MACRO4(202B(*MOVEM*),BASIS,NEWREG,-1);
MACRO4(202B(*MOVEM*),TOPP,NEWREG,-2);
SUPPORT(FORTRANRESET);
GENERATE←WORD(NO,0,0);
MACRO3(554B(*HLRZ*),REG1,JBSA);
MACRO4(200B(*MOVE*),NEWREG,REG1,-1);
MACRO4(200B(*MOVE*),BASIS,REG1,-2);
MACRO4(200B(*MOVE*),TOPP,REG1,-3)
END;
IF NOT DEBUG AND RUNTIME←CHECK
THEN
BEGIN
MACRO3(551B(*HRRZI*),REG1,110B); (*ENABLE OVERFLOW*)
MACRO3(047B,REG1,16B(*APRENB-UUO*))
END
END;
REGC := REGIN + 1; LPARMPTR := PARMPTR;
IF EXTERNAL OR (PARMPTR = NIL)
THEN
BEGIN
ALFACONSTANT(PROGRAMNAME);
NAME←ADDRESS := IC;
MACRO2(551B(*HRRZI*),REGC+2); DEPOSIT←CONSTANT(STRG,GATTR)
END;
IF NOT EXTERNAL
THEN
BEGIN
IF PARMPTR <> NIL
THEN
NAME←ADDRESS := IC;
WHILE LPARMPTR <> NIL DO
WITH LPARMPTR↑ DO
BEGIN
IF FILEIDPTR <> NIL
THEN
WITH FILEIDPTR↑ DO
BEGIN
ALFACONSTANT(PROGRAMNAME);
MACRO2(551B(*HRRZI*),REGC+2); DEPOSIT←CONSTANT(STRG,GATTR);
MACRO3R(551B(*HRRZI*),REGC,VADDR);
ALFACONSTANT(NAME);
MACRO2(551B(*HRRZI*),REGC+1); DEPOSIT←CONSTANT(STRG,GATTR);
IF NOT INPUTFILE
THEN
MACRO2(400B(*SETZ*),REGC+3)
ELSE
MACRO3(551B(*HRRZI*),REGC+3,1);
SUPPORT(READPGMPARAMETER)
END
ELSE
ERROR←WITH←TEXT(264,FILEID);
LPARMPTR := NEXTPTP
END;
FOR I := 1 TO 4 DO MACRO2(400B(*SETZ*),REGC+I);
IF PARMPTR = NIL
THEN
BEGIN
MACRO3R(551B(*HRRZI*),REGC,STDFILEPTR[1]↑.VADDR);
SUPPORT(RESETFILE);
MACRO3R(551B(*HRRZI*),REGC,STDFILEPTR[2]↑.VADDR);
SUPPORT(REWRITEFILE);
END;
MACRO3R(551B(*HRRZI*),REGC,STDFILEPTR[4]↑.VADDR);
MACRO4(336B(*SKIPN*),0,REGC,FILBHP);
SUPPORT(REWRITEFILE);
IF TTYREAD
THEN
BEGIN
SUPPORT(OPENTTY);
ALFACONSTANT('TTY ');
MACRO2(551B(*HRRZI*),REGC+1); DEPOSIT←CONSTANT(STRG,GATTR);
MACRO3R(551B(*HRRZI*),REGC,STDFILEPTR[3]↑.VADDR);
MACRO4(200B(*MOVE*),REGC+5,REGC,FILDEV);
MACRO3(302B(*CAIE*),REGC+5,TTY←SIXBIT);
MACRO3(550B(*HRRZ*),REGC+4,REGC+1);
SUPPORT(RESETFILE)
END;
MACRO3(552B(*HRRZM*),BASIS,DEBUG←STACKBOTTOM + SYSTEM←LOW←START);
MACRO3(332B(*SKIPE*),REG0,DEBUG←INITIALIZATION + SYSTEM←LOW←START);
MACRO3(256B(*XCT*),REG0,DEBUG←INITIALIZATION + SYSTEM←LOW←START);
MACRO3R(254B(*JRST*),REG0,MAIN←START);
IF DEBUG
THEN SUPPORT(LOADDEBUG)
END
END;
CODEEND := IC;
LKSP:= FIRSTKONST;
WHILE LKSP <> NIL DO
WITH LKSP↑,CONSTPTR↑ DO
BEGIN
KADDR:= IC;
WITH ICCHANGE DO
BEGIN
ICVAL := IC; SELFCSP :=ICCSP
END;
NOCODE := FALSE;
CASE CCLASS OF
INT,
BPTR,
REEL:
IC := IC + 1 ;
PSET:
IC := IC + 2 ;
STRD,
STRG:
IC := IC + (SLGTH+4) DIV 5
END (*CASE*);
LKSP := NEXTKONST
END (*WITH , WHILE*);
LDECLSCALPTR := DECLSCALPTR;
WHILE LDECLSCALPTR <> NIL DO
WITH LDECLSCALPTR↑ DO
IF (LEVEL = TLEV) OR ((LEVEL = 1) AND (TLEV = 0))
THEN
BEGIN
IF REQUEST
THEN
BEGIN
IC := IC+2*DIMENSION; VECTORADDR := IC; IC := IC + 2
END;
LDECLSCALPTR := NEXTSCALAR
END
ELSE LDECLSCALPTR := NIL;
IF DEBUG←SWITCH
THEN
BEGIN
LCP := DISPLAY[TOP].FNAME;
IF (LEVEL > 1) AND ( LCP <> NIL )
THEN
BEGIN
IF LCP↑.SELFCTP = NIL
THEN I:= IC
ELSE I := ORD(LCP↑.SELFCTP);
INSERT←ADDRESS(RIGHT,IDTREE,I)
END
END;
IF LEVEL = 1
THEN HIGHEST←CODE := IC
END(*LEAVEBODY*);
PROCEDURE FETCH←BASIS(VAR FATTR: ATTR);
VAR
P,Q: INTEGER;
BEGIN
WITH FATTR DO
IF VLEVEL>1
THEN
BEGIN
P := LEVEL - VLEVEL;
IF P=0
THEN
IF INDEXR=0
THEN INDEXR := BASIS
ELSE MACRO3(270B(*ADD*),INDEXR,BASIS)
ELSE
BEGIN
MACRO4(550B(*HRRZ*),REG1,BASIS,-1);
FOR Q := P DOWNTO 2 DO
MACRO4(550B(*HRRZ*),REG1,REG1,-1);
IF INDEXR=0
THEN INDEXR := REG1
ELSE MACRO4(271B(*ADDI*),INDEXR,REG1,0)
END;
(*DA IN WITH-STATEMENT DIE MOEGLICHKEIT BESTEHT,
DASS FETCH←BASIS 2-MAL AKTIVIERT WIRD*)
VLEVEL := 1
END
END;
(*FETCH←BASIS*)
PROCEDURE GET←PARAMETER←ADDRESS;
BEGIN
FETCH←BASIS(GATTR);
WITH GATTR DO
BEGIN
INCREMENT←REGC;
MACRO5(VRELBYTE,200B(*MOVE*),REGC,INDEXR,DPLMT);
INDEXR := REGC; VRELBYTE:= NO;
INDBIT := 0; VLEVEL := 1; DPLMT := 0
END
END;
PROCEDURE GENERATE←CODE(FINSTR: INSTRANGE; FAC: ACRANGE; VAR FATTR: ATTR);
VAR
LINSTR: INSTRANGE;
LREGC: ACRANGE;
LATTR: ATTR;
LRELBYTE: RELBYTE;
LABS: INTEGER;
BEGIN
LRELBYTE := RIGHT;
WITH FATTR DO
IF TYPTR<>NIL
THEN
BEGIN
CASE KIND OF
CST:
IF TYPTR=REALPTR
THEN
BEGIN
MACRO3(FINSTR,FAC,0); DEPOSIT←CONSTANT(REEL,FATTR)
END
ELSE
IF TYPTR↑.FORM=SCALAR
THEN
WITH CVAL DO
BEGIN
IF IVAL = -MAXINT - 1
THEN LABS := MAXINT
ELSE LABS := ABS(IVAL);
IF ((IVAL >= 0) AND (IVAL <= MAXADDR))
OR
((LABS <= HWCSTMAX+1) AND (FINSTR = 200B(*MOVE*)))
THEN
BEGIN
IF FINSTR=200B(*MOVE*)
THEN
IF IVAL < 0
THEN FINSTR := 561B(*HRROI*)
ELSE FINSTR := 551B(*HRRZI*)
ELSE
IF (FINSTR>=311B) AND (FINSTR <= 317B)
THEN FINSTR := FINSTR - 10B (*E.G. CAML --> CAIL*)
ELSE FINSTR := FINSTR+1;
MACRO3(FINSTR,FAC,IVAL)
END
ELSE
BEGIN
MACRO3(FINSTR,FAC,0); DEPOSIT←CONSTANT(INT,FATTR)
END
END
ELSE
IF TYPTR=NILPTR
THEN
BEGIN
IF FINSTR=200B(*MOVE*)
THEN FINSTR := 551B(*HRRZI*)
ELSE
IF (FINSTR>=311B) AND (FINSTR<=317B)
THEN FINSTR := FINSTR-10B
ELSE FINSTR := FINSTR+1;
MACRO3(FINSTR,FAC,377777B)
END
ELSE
IF TYPTR↑.FORM=POWER
THEN
BEGIN
MACRO3(FINSTR,FAC,0); MACRO3(FINSTR,FAC-1,0); DEPOSIT←CONSTANT(PSET,FATTR)
END
ELSE
IF TYPTR↑.FORM=ARRAYS
THEN
IF TYPTR↑.SIZE = 1
THEN
BEGIN
MACRO3(FINSTR,FAC,0); DEPOSIT←CONSTANT(STRG,FATTR)
END
ELSE
IF TYPTR↑.SIZE = 2
THEN
BEGIN
FATTR.CVAL.VALP↑.CCLASS := STRD;
MACRO3(FINSTR,FAC,0); MACRO3(FINSTR,FAC-1,0); DEPOSIT←CONSTANT(STRD,FATTR)
END;
VARBL:
BEGIN
FETCH←BASIS(FATTR); LREGC := FAC;
IF (INDEXR>REGIN) AND (INDEXR<=REGCMAX) AND ((PACKFG<>NOTPACK) OR (FINSTR=200B(*MOVE*)))
THEN
IF (TYPTR↑.SIZE = 2) AND LOADNOPTR
THEN LREGC := INDEXR+1
ELSE LREGC := INDEXR
ELSE
IF (PACKFG<>NOTPACK) AND (FINSTR<>200B(*MOVE*))
THEN
BEGIN
INCREMENT←REGC; LREGC := REGC
END;
CASE PACKFG OF
NOTPACK:
BEGIN
IF (TYPTR↑.SIZE = 2) AND LOADNOPTR
THEN
BEGIN
MACRO5(VRELBYTE,FINSTR,LREGC,INDEXR,DPLMT+1);
MACRO5(VRELBYTE,FINSTR,LREGC-1,INDEXR,DPLMT)
END
ELSE MACRO(VRELBYTE,FINSTR,LREGC,INDBIT,INDEXR,DPLMT)
END;
PACKK:
BEGIN
IF VCLASS = FIELD
THEN
BEGIN
WITH LATTR, CVAL, BYTE DO
BEGIN
KIND := CST;
CVAL.BYTE := FATTR.VBYTE;
IBIT := ORD(FATTR.VRELBYTE);
IREG := FATTR.INDEXR;
RELADDR := RELADDR + FATTR.DPLMT
END;
MACRO2(135B(*LDB*),LREGC); DEPOSIT←CONSTANT(BPTR,LATTR)
END
ELSE
BEGIN
MACRO5(VRELBYTE,551B(*HRRZI*),REG1,INDEXR,DPLMT);
IF (BPADDR>REGIN) AND (BPADDR<=REGCMAX)
THEN
IF (INDEXR<=REGIN) OR (BPADDR<INDEXR)
THEN LREGC := BPADDR
ELSE LREGC := INDEXR;
IF BPADDR < HIGH←START
THEN LRELBYTE := NO;
MACRO5(LRELBYTE,135B(*LDB*),LREGC,0,BPADDR)
END
END;
HWORDL:
MACRO5(VRELBYTE,554B(*HLRZ*),LREGC,INDEXR,DPLMT);
HWORDR:
MACRO5(VRELBYTE,550B(*HRRZ*),LREGC,INDEXR,DPLMT)
END (*CASE*);
IF (FINSTR<>200B(*MOVE*)) AND (PACKFG<>NOTPACK)
THEN MACRO3(FINSTR,FAC,LREGC)
ELSE FAC := LREGC
END;
EXPR:
IF FINSTR <> 200B(*MOVE*)
THEN
BEGIN
MACRO3(FINSTR,FAC,REG);
IF TYPTR↑.SIZE = 2
THEN MACRO3(FINSTR,FAC-1,REG-1)
END
END (*CASE*);
KIND := EXPR; REG := FAC
END
END (*GENERATE←CODE*);
PROCEDURE LOAD(VAR FATTR: ATTR);
VAR
LINSTR: INSTRANGE;
BEGIN
WITH FATTR DO
IF TYPTR<>NIL
THEN
IF KIND<>EXPR
THEN
BEGIN
INCREMENT←REGC ; LINSTR := 200B(*MOVE*);
IF (TYPTR↑.SIZE = 2) AND LOADNOPTR
THEN INCREMENT←REGC ;
GENERATE←CODE(LINSTR,REGC,FATTR); REGC := REG
END
END (*LOAD*) ;
PROCEDURE STORE(FAC: ACRANGE; VAR FATTR: ATTR);
VAR
LATTR: ATTR; LATTRC: ATTR; LRELBYTE: RELBYTE;
BEGIN
LATTR := FATTR; LRELBYTE := RIGHT;
WITH LATTR DO
IF TYPTR <> NIL
THEN
BEGIN
FETCH←BASIS(LATTR);
CASE PACKFG OF
NOTPACK:
BEGIN
IF TYPTR↑.SIZE = 2
THEN
BEGIN
MACRO5(VRELBYTE,202B(*MOVEM*),FAC,INDEXR,DPLMT+1); FAC := FAC-1
END;
MACRO(VRELBYTE,202B(*MOVEM*),FAC,INDBIT,INDEXR,DPLMT)
END;
PACKK:
IF VCLASS = FIELD
THEN
BEGIN
WITH LATTRC, CVAL, BYTE DO
BEGIN
KIND := CST;
CVAL.BYTE := LATTR.VBYTE;
IBIT := ORD(LATTR.VRELBYTE);
IREG := LATTR.INDEXR;
RELADDR := RELADDR + LATTR.DPLMT
END;
MACRO2(137B(*DPB*),FAC); DEPOSIT←CONSTANT(BPTR,LATTRC)
END
ELSE
BEGIN
MACRO5(VRELBYTE,551B(*HRRZI*),REG1,INDEXR,DPLMT);
IF BPADDR < HIGH←START
THEN LRELBYTE := NO;
MACRO5(LRELBYTE,137B(*DPB*),FAC,0,BPADDR)
END;
HWORDL:
MACRO5(VRELBYTE,506B(*HRLM*),FAC,INDEXR,DPLMT);
HWORDR:
MACRO5(VRELBYTE,542B(*HRRM*),FAC,INDEXR,DPLMT)
END (*CASE*)
END (*WITH*)
END (*STORE*) ;
PROCEDURE LOAD←ADDRESS;
BEGIN
INCREMENT←REGC ;
BEGIN
WITH GATTR DO
IF TYPTR <> NIL
THEN
BEGIN
CASE KIND OF
CST:
IF STRING(TYPTR)
THEN
BEGIN
MACRO3(551B(*HRRZI*),REGC,0);
DEPOSIT←CONSTANT(STRG,GATTR)
END
ELSE ERROR(171);
VARBL:
BEGIN
IF (INDEXR>REGIN) AND (INDEXR <= REGCMAX)
THEN REGC := INDEXR;
FETCH←BASIS(GATTR);
CASE PACKFG OF
NOTPACK:
MACRO(VRELBYTE,551B(*HRRZI*),REGC,INDBIT,INDEXR,DPLMT);
PACKK,HWORDL,HWORDR:
ERROR(357)
END;
IF TYPTR↑.FORM = FILES
THEN
IF LAST←FILE <> NIL
THEN
WITH LAST←FILE↑ DO
IF (VLEV = 0) AND EXTERNAL
THEN
BEGIN
VADDR := IC-1; CODE←REFERENCE↑[CIX] := EXTERNREF
END
END;
EXPR:
ERROR(171)
END;
KIND := VARBL; DPLMT := 0; INDEXR:=REGC; INDBIT:=0; VRELBYTE := NO; VCLASS := VARS
END
END
END (*LOAD←ADDRESS*) ;
PROCEDURE WRITE←MACHINE←CODE(WRITE←FLAG:WRITE←FORM);
TYPE
BIGALFA = PACKED ARRAY[1..20] OF CHAR ;
VAR
LLIST←CODE, PUT←CODE←ARRAY: BOOLEAN;
LIC, LICMOD4: ADDRRANGE;
SPACE←C, SPACE←W: INTEGER;
PROCEDURE NEW←LINE;
BEGIN
LICMOD4 := LIC MOD 4;
IF (LICMOD4 = 0) AND LIST←CODE AND (LIC > 0)
THEN
BEGIN
WRITELN(LIST);
WITH RELOCATION←BLOCK DO
BEGIN
IF ITEM = ITEM←1
THEN WRITE(LIST, LIC:6:O, SHOWRELO[RELOCATOR[0] = RIGHT])
ELSE WRITE(LIST,' ':7)
END
END
END (*NEW←LINE*) ;
PROCEDURE PUT←RELOCATABLE←CODE;
VAR
I: INTEGER;
BEGIN
WITH RELOCATION←BLOCK DO
BEGIN
IF ((COUNT > 1) OR (ITEM <> ITEM←1)) AND (COUNT > 0)
THEN
BEGIN
FOR I:= COUNT+1 TO 18 DO RELOCATOR[I-1] := NO;
FOR I:= 1 TO COUNT+2 DO
BEGIN
OBJECT↑:= COMPONENT[I];
PUT(OBJECT)
END
END;
COUNT := 0
END
END;
PROCEDURE WRITE←BLOCK←START(FRELBYTE: RELBYTE; FLIC: ADDRRANGE; FITEM: ADDRRANGE);
VAR
CHANGE: PACKED RECORD
CASE BOOLEAN OF
TRUE: (WKONST: INTEGER);
FALSE:(WLEFTHALF: ADDRRANGE; WRIGHTHALF: ADDRRANGE)
END;
BEGIN
WITH RELOCATION←BLOCK , CHANGE DO
BEGIN
IF COUNT <> 0
THEN PUT←RELOCATABLE←CODE;
ITEM := FITEM;
LIC := FLIC;
IF ITEM = ITEM←1
THEN
BEGIN
WLEFTHALF:= 0;
WRIGHTHALF:= LIC;
CODE[0]:= WKONST;
RELOCATOR[0] := FRELBYTE;
COUNT:= 1
END
END
END;
PROCEDURE WRITE←WORD(FRELBYTE: RELBYTE; FWORD: INTEGER);
VAR
CHANGE: PACKED RECORD
CASE BOOLEAN OF
TRUE: (WKONST: INTEGER);
FALSE:(WLEFTHALF: ADDRRANGE; WRIGHTHALF: ADDRRANGE)
END;
BEGIN
WITH CHANGE DO
BEGIN
WKONST := FWORD;
WITH RELOCATION←BLOCK DO
BEGIN
IF COUNT = 0
THEN WRITE←BLOCK←START(RELOCATOR[0],LIC,ITEM);
CODE[COUNT]:= FWORD;
IF NOT PUT←CODE←ARRAY
THEN
BEGIN
IF FRELBYTE IN [LEFT,BOTH]
THEN
IF (WLEFTHALF = 0) OR (WLEFTHALF = 377777B)
THEN
IF FRELBYTE = BOTH
THEN FRELBYTE := RIGHT
ELSE FRELBYTE := NO;
IF FRELBYTE IN [RIGHT,BOTH]
THEN
IF (WRIGHTHALF = 0) OR (WRIGHTHALF = 377777B)
THEN
IF FRELBYTE = BOTH
THEN FRELBYTE := LEFT
ELSE FRELBYTE := NO
END;
RELOCATOR[COUNT]:= FRELBYTE;
COUNT := COUNT+1;
IF COUNT = 18
THEN PUT←RELOCATABLE←CODE
END;
IF LLIST←CODE
THEN
BEGIN
NEW←LINE;
IF LIC > 0
THEN
IF LICMOD4 = 0
THEN WRITE(LIST,' ':13)
ELSE WRITE(LIST,' ':11,' ':SPACE←W);
IF WRITE←FLAG > WRITE←FILEBLOCKS
THEN WRITE(LIST,' ':7)
ELSE WRITE(LIST,WLEFTHALF:6:O, SHOWRELO[ FRELBYTE IN [LEFT,BOTH] ] );
WRITE(LIST,WRIGHTHALF:6:O, SHOWRELO[ FRELBYTE IN [RIGHT,BOTH] ], ' ':3)
END;
LIC := LIC + 1;
SPACE←W := 2
END
END;
FUNCTION RADIX50( FNAME: ALFA): RADIXRANGE;
VAR
I: INTEGER; C: CHAR; OCTALCODE, RADIXVALUE: RADIXRANGE;
BEGIN
RADIXVALUE:= 0;
I:=1; C := FNAME[1];
WHILE (C <> ' ') AND (I <= 6) DO
BEGIN
IF C IN DIGITS
THEN OCTALCODE:= ORD(C)-ORD('0')+1
ELSE
IF C IN LETTERS
THEN OCTALCODE:= ORD(C)-ORD('A')+11
ELSE
IF C = '.'
THEN OCTALCODE:= 37
ELSE
IF C = '$'
THEN OCTALCODE:= 38
ELSE
IF C = '%'
THEN OCTALCODE:= 39;
RADIXVALUE:= RADIXVALUE*50B+OCTALCODE; I:=I+1; C := FNAME[I]
END;
RADIX50:= RADIXVALUE
END;
PROCEDURE WRITE←PAIR( FRELBYTE: RELBYTE; FADDR1, FADDR2: ADDRRANGE);
BEGIN
WITH CHANGE DO
BEGIN
WLEFTHALF:= FADDR1;
WRIGHTHALF:= FADDR2;
WRITE←WORD(FRELBYTE,WKONST)
END
END;
PROCEDURE WRITE←IDENTIFIER( FFLAG: FLAGRANGE; FSYMBOL: ALFA);
BEGIN
LLIST←CODE := FALSE;
WITH CHANGE DO
BEGIN
IF LIST←CODE AND (WRITE←FLAG > WRITE←HISEG)
THEN
BEGIN
IF LIC > 0
THEN
BEGIN
IF LIC MOD 4 = 0
THEN
BEGIN
WRITELN(LIST); WRITE(LIST,' ':7)
END;
WRITE(LIST,' ':13)
END;
WRITE(LIST,FSYMBOL:6,' ':11)
END;
IF FFLAG <> SIXBIT←SYMBOL
THEN
BEGIN
FLAG:= FFLAG; SYMBOL:= RADIX50(FSYMBOL)
END;
WRITE←WORD(NO,WKONST); LLIST←CODE := LIST←CODE
END
END;
PROCEDURE WRITE←FIRST←LINE ;
BEGIN
IF LIST←CODE
THEN
BEGIN
WRITELN(LIST);
LICMOD4 := LIC MOD 4;
IF LICMOD4 > 0
THEN
WRITE(LIST,(LIC-LICMOD4):6:O,SHOWRELO[RELOCATION←BLOCK.RELOCATOR[0] = RIGHT],' ':LICMOD4*30)
END
END ;
PROCEDURE WRITE←HEADER(FTEXT: BIGALFA);
BEGIN
IF LIST←CODE
THEN
BEGIN
WRITELN(LIST); WRITELN(LIST); WRITE(LIST,FTEXT:16,':',' ':3); LIC := 0
END
END;
PROCEDURE WRITE←CONSTANT(FCST: CSTCLASS);
VAR
I, J: INTEGER; LRELBYTE: RELBYTE;
BEGIN
WITH CHANGE DO
BEGIN
IF (FCST = BPTR) AND (WBYTE.IBIT <> 0)
THEN
BEGIN
WBYTE.IBIT := 0; LRELBYTE := RIGHT
END
ELSE LRELBYTE := NO;
IF LIST←CODE
THEN
BEGIN
NEW←LINE;
IF LICMOD4 = 0
THEN WRITE(LIST,' ':8)
ELSE WRITE(LIST,' ':6,' ':SPACE←C);
CASE FCST OF
INT:
WRITE(LIST,'[',' ':10,WKONST,']');
REEL:
WRITE(LIST,'[',' ':5,WREAL,']');
STRD,
STRG:
BEGIN
WRITE(LIST,'[',' ':15,''''); J := 0;
FOR I := 1 TO 5 DO
IF NOT (WSTRING[I] IN [' '..'←'])
THEN J := J + 1
ELSE WRITE(LIST,WSTRING[I]);
WRITE(LIST,'''',' ':J,']')
END;
PSET:
WRITE(LIST,'[',' ':10,WKONST:12:O,']');
BPTR:
WITH WBYTE DO
WRITE(LIST, 'POINT ', SBITS:2, ', ',
RELADDR:5:O, SHOWRELO[(LRELBYTE = RIGHT)], '(',
IREG:2:O, '),', 35-PBITS:2)
END
END;
WRITE←WORD(LRELBYTE,WKONST);
SPACE←C := 0
END
END;
PROCEDURE CODE←FOR←FILEBLOCKS;
VAR
STOPPTR, LFILEPTR: FTP;
I: INTEGER;
FILBLOCKADR: ADDRRANGE;
(* IMPLEMENTATION OF FILES IN DECSYSTEM-10 PASCAL
FILE TYPE PACKED UNPACKED
------------------------------------------------
(SUBRANGE OF) ASCII-MODE, BINARY-MODE,
CHAR FORMATTED I/O, STANDARD I/O,
"UPPER CASE", "FULL BOARD"
LINENUMBERS &
PAGEMARKS
(SUBRANGE OF) ASCII-MODE, AS ABOVE
ASCII STANDARD I/O,
"FULL BOARD"
OTHER TREATED AS ABOVE
AS UNPACKED
*)
BEGIN
(*CODE←FOR←FILEBLOCKS*)
LFILEPTR:= FILEPTR;
IF NOT EXTERNAL
THEN STOPPTR := NIL
ELSE STOPPTR := SFILEPTR;
WHILE LFILEPTR <> STOPPTR DO
WITH LFILEPTR↑, FILEIDENT↑, CHANGE DO
IF IDTYPE=NIL
THEN
BEGIN
ERROR(171); LFILEPTR:=STOPPTR
END
ELSE
BEGIN
FILBLOCKADR := VADDR ;
WRITE←BLOCK←START(RIGHT,FILBLOCKADR,ITEM←1); WRITE←FIRST←LINE;
WLEFTHALF := IDTYPE↑.FILE←FORM;
WRIGHTHALF := FILBLOCKADR + FILCMP;
WRITE←WORD(RIGHT,WKONST) ;
WRITE←WORD(NO,0) ; WRITE←WORD(NO,0) ; (*RESERVE LOCATIONS FOR FILEOF AND FILEOL*)
WKONST := 0;
WINSTR.INSTR := 50B (*OPEN*) ; WINSTR.AC := CHANNEL ;
WINSTR.ADDRESS := FILBLOCKADR + FILSTA ;
WRITE←WORD(RIGHT,WKONST) (*FILOPN*) ;
WINSTR.INSTR := 76B (*LOOKUP*) ; WINSTR.ADDRESS := FILBLOCKADR + FILNAM ; WRITE←WORD(RIGHT,WKONST) ;
WINSTR.INSTR := 77B (*ENTER*) ; WRITE←WORD(RIGHT,WKONST) ;
WINSTR.ADDRESS := 0 ;
WINSTR.INSTR := 56B (* IN*) ; WRITE←WORD(NO,WKONST) ;
WINSTR.INSTR := 57B (*OUT*) ; WRITE←WORD(NO,WKONST) ;
WINSTR.INSTR := 70B (*CLOSE*) ; WRITE←WORD(NO,WKONST) ;
WRITE←WORD(NO, IDTYPE↑.FILE←MODE);
IF (NAME = 'TTYOUTPUT ') OR (NAME = 'TTY ')
THEN WLEFTHALF := TTY←SIXBIT
ELSE WLEFTHALF := DSK←SIXBIT;
WRIGHTHALF := 0;
WRITE←WORD(NO,WKONST);
WRITE←WORD(NO,0) ; (*BUFFERHEADER ADDRESS INSERTED DURING RESET OR REWRITE*)
FOR I := 1 TO 6 DO WSIXBIT[I] := ORD( NAME[I] ) - 40B ; WRITE←WORD(NO,WKONST) ;
WKONST := 0 ;
FOR I := 1 TO 3 DO WSIXBIT[I] := ORD( NAME[I+6] ) - 40B ; WRITE←WORD(NO,WKONST) ;
FOR I := 1 TO 6 DO WRITE←WORD(NO, 0 ) (*ZERO IN FILPROT, FILPPN, FILBFH, FILBTP, FILBTC,FILLNR*) ;
WLEFTHALF := - IDTYPE↑.FILTYPE↑.SIZE ; WRIGHTHALF := FILBLOCKADR + FILCMP ;
WRITE←WORD(RIGHT,WKONST) (*FILCNT*) ;
FOR I := 1 TO IDTYPE↑.FILTYPE↑.SIZE DO WRITE←WORD(NO, 0 ) (*CLEAR COMPONENT LOCATIONS *) ;
LFILEPTR := NEXTFTP
END
END (*CODE←FOR←FILEBLOCKS*);
PROCEDURE CODE←FOR←INSTRUCTIONS;
VAR
I, J, NN: INTEGER;
LBYTE: BPOINTER; LDECLSCALPTR: STP; LFCONST: CTP;
LRELBYTE: RELBYTE; LFIRSTKONST: KSP; LREFERENCE: CODEREFS;
STRING: ARRAY[1..6] OF CHAR;
BEGIN
(*CODE←FOR←INSTRUCTIONS*)
LLIST←CODE:= FALSE;
IF LIST←CODE
THEN WRITEBUFFER;
IF LASTBTP <> NIL
THEN
BEGIN
WRITE←BLOCK←START(RIGHT,LASTBTP↑.ARRAYSP↑.ARRAYBPADDR,ITEM←1); WRITE←FIRST←LINE;
WHILE LASTBTP <> NIL DO
BEGIN
WITH LASTBTP↑, ARRAYBPS[BITSIZE] DO
BEGIN
LBYTE := ABYTE;
IF STATE = CALCULATED
THEN
BEGIN
NN := BYTEMAX; STATE:= USED
END
ELSE NN:=0
END;
FOR I:=1 TO NN DO
BEGIN
WITH CHANGE DO
BEGIN
WBYTE := LBYTE; WRITE←CONSTANT(BPTR)
END;
WITH LBYTE DO PBITS := PBITS - SBITS
END (*FOR*);
LASTBTP := LASTBTP↑.LAST
END (* WHILE*)
END (*LASTBTP<>NIL*) ;
PUT←CODE←ARRAY := TRUE;
WRITE←BLOCK←START(RIGHT,CODEEND-CIX-1,ITEM←1); WRITE←FIRST←LINE;
IF LIST←CODE AND (LICMOD4 <> 0)
THEN WRITE(LIST,' ':2);
FOR I := 0 TO CIX DO
WITH CODE←ARRAY↑, INSTRUCTION[I] DO
BEGIN
LRELBYTE := CODE←RELOCATION↑[I];
LREFERENCE := CODE←REFERENCE↑[I];
IF (LREFERENCE IN [EXTERNREF,CONSTREF,FORWARDREF,GOTOREF,POINTREF,SAVEREF,DEBUGREF]) AND (ADDRESS = 0)
THEN LRELBYTE := NO;
IF LIST←CODE
THEN
BEGIN
NEW←LINE;
IF LICMOD4 = 0
THEN WRITE(LIST,' ':8)
ELSE WRITE(LIST,' ':6);
CASE LREFERENCE OF
NOINSTR:
WITH HALFWORD[I] DO
WRITE(LIST,' ':5,LEFTHALF :6:O, SHOWRELO[LRELBYTE IN [LEFT,BOTH]],
RIGHTHALF:6:O, SHOWRELO[LRELBYTE IN [RIGHT,BOTH]],' ':5);
OTHERS:
BEGIN
UNPACK(MNEMONICS[(INSTR+9) DIV 10],STRING,1,((INSTR+9) MOD 10)*6+1,6);
WRITE(LIST,STRING:6, ' ',AC:2:O,', ', SHOWIBIT[INDBIT],
ADDRESS:6:O, SHOWRELO[LRELBYTE IN [RIGHT,BOTH]]);
IF INXREG > 0
THEN WRITE(LIST,'(',INXREG:2:O,')',SHOWREF[LREFERENCE])
ELSE WRITE(LIST,' ':4,SHOWREF[LREFERENCE])
END
END (*CASE*)
END;
WRITE←WORD(LRELBYTE,WORD[I])
END (*FOR *) ;
PUT←CODE←ARRAY := FALSE;
IF (FIRSTKONST <> NIL) OR (DECLSCALPTR <> NIL)
THEN
BEGIN
LFIRSTKONST := FIRSTKONST;
WRITE←BLOCK←START(RIGHT,LIC,ITEM←1); WRITE←FIRST←LINE;
IF LIST←CODE AND (LICMOD4 <> 0)
THEN WRITE(LIST,' ':2);
WHILE LFIRSTKONST <> NIL DO
BEGIN
WITH LFIRSTKONST↑.CONSTPTR↑, CHANGE DO
BEGIN
CASE CCLASS OF
INT,
REEL:
WKONST := INTVAL;
PSET:
BEGIN
WKONST := INTVAL; WRITE←CONSTANT(CCLASS);
WKONST := INTVAL1
END;
BPTR:
WBYTE := BYTE;
STRD,
STRG:
BEGIN
J :=0; WKONST := 0;
FOR I := 1 TO SLGTH DO
BEGIN
J := J+1;
WSTRING[J] := SVAL[I];
IF J=5
THEN
BEGIN
J := 0;
WRITE←CONSTANT(CCLASS);
WKONST := 0
END
END
END
END;
IF NOT (CCLASS IN [STRD,STRG]) OR (J <> 0)
THEN WRITE←CONSTANT(CCLASS)
END;
LFIRSTKONST := LFIRSTKONST↑.NEXTKONST
END (*WHILE*) ;
LDECLSCALPTR := DECLSCALPTR;
WHILE LDECLSCALPTR <> NIL DO
WITH LDECLSCALPTR↑ DO
IF (LEVEL = TLEV) OR ((LEVEL = 1) AND (TLEV = 0))
THEN
BEGIN
IF REQUEST
THEN
BEGIN
LFCONST := FCONST;
WHILE LFCONST <> NIL DO
WITH LFCONST↑ DO
BEGIN
FOR J := 0 TO 1 DO
WITH CHANGE DO
BEGIN
WKONST := 0;
FOR I := 1 TO 5 DO
WSTRING[I] := NAME[I+J*5];
WRITE←CONSTANT(STRD)
END;
LFCONST := NEXT
END
END;
LDECLSCALPTR := NEXTSCALAR
END
ELSE LDECLSCALPTR := NIL
END;
IF LEVEL = 1
THEN
BEGIN
JUMP←ADDRESS := LCMAIN;
LCMAIN := LCMAIN + 2 * JUMPER
END;
IF NOT DEBUG AND (LEVEL = 1)
THEN
BEGIN
LLIST←CODE := LIST←CODE;
IF LIST←CODE
THEN
BEGIN
WRITELN(LIST); WRITE(LIST,DEBUG←SAVE:6:O,'''',' ':13)
END;
WRITE←BLOCK←START(RIGHT,DEBUG←SAVE,ITEM←1);
FOR I := DEBUG←SAVE TO DEBUG←PROGRAMNAME DO
WRITE←WORD(NO,0)
END
END (*CODE←FOR←INSTRUCTIONS*);
PROCEDURE CODE←FOR←GLOBALS;
VAR
I, J: INTEGER;
BEGIN
(*CODE←FOR←GLOBALS*)
IF LIST←CODE AND (FGLOBPTR <> NIL)
THEN WRITEBUFFER;
WHILE FGLOBPTR <> NIL DO
WITH FGLOBPTR↑ DO
BEGIN
J := FCIX ;
WRITE←BLOCK←START(RIGHT,FIRSTGLOB,ITEM←1); WRITE←FIRST←LINE;
FOR I := FIRSTGLOB TO LASTGLOB DO
BEGIN
CHANGE.WINSTR := CODE←ARRAY↑.INSTRUCTION[J] ; J := J + 1 ;
WRITE←WORD(NO,CHANGE.WKONST)
END ;
FGLOBPTR := NEXTGLOBPTR
END
END (*CODE←FOR←GLOBALS*);
PROCEDURE CODE←FOR←DEBUG;
CONST
MAXSIZE (*OF CONSTANT-, STRUCTURE-, AND IDENTIFIER-RECORD*) = 24 (*WORDS*) ;
TYPE
RECORDFORM = (UNSPECIFIC, CONST←REC, STRUCT←REC,
IDENT←REC, DEBUG←REC);
VAR
LNLK : NLK;
LCP: CTP;
LSIZE: 1..MAXSIZE; RUN1: BOOLEAN;
RELARRAY, RELEMPTY: ARRAY[1..MAXSIZE] OF RELBYTE;
ICCHANGE: PACKED RECORD
CASE INTEGER OF
1:(ICVAL: ADDRRANGE);
2:(ICCSP: CSP);
3:(ICCTP: CTP);
4:(ICSTP: STP)
END;
RECORDCHANGE: PACKED RECORD
CASE RECORDFORM OF
UNSPECIFIC: (WORD:ARRAY[1..MAXSIZE] OF INTEGER);
CONST←REC: (STRING1: PACKED ARRAY[1..STRGLGTH] OF CHAR);
STRUCT←REC: (STRUCTREC: STRUCTURE);
IDENT←REC: (IDENTREC: IDENTIFIER);
DEBUG←REC: (DEBUGREC: DEBENTRY)
END;
PROCEDURE WRITE←RECORD(RECORD←FORM: RECORDFORM);
VAR
I, J: INTEGER;
BEGIN
LLIST←CODE := FALSE;
SPACE←C := 2;
CASE RECORD←FORM OF
IDENT←REC :
J := 2;
CONST←REC :
J := LSIZE;
OTHERS :
J := 0;
END;
IF J <> 0
THEN
BEGIN
FOR I := 1 TO J DO
BEGIN
CHANGE.WKONST := RECORDCHANGE.WORD[I];
WRITE←CONSTANT(STRG)
END;
SPACE←W := 0
END;
LLIST←CODE := LIST←CODE;
FOR I := J + 1 TO LSIZE DO WRITE←WORD(RELARRAY[I], RECORDCHANGE.WORD[I] )
END;
PROCEDURE COPYCSP(FCSP:CSP);
BEGIN
IF FCSP <> NIL
THEN
WITH FCSP↑ DO
BEGIN
IF CCLASS IN [STRG,STRD]
THEN LSIZE := (SLGTH + 4) DIV 5
ELSE ERROR(171);
IF RUN1
THEN
BEGIN
IF SELFCSP = NIL
THEN WITH ICCHANGE DO
BEGIN
ICVAL := IC; SELFCSP := ICCSP;
NOCODE := TRUE;
IC := IC + LSIZE
END
END
ELSE
IF NOCODE
THEN
BEGIN
RECORDCHANGE.STRING1 := FCSP↑.SVAL;
RELARRAY := RELEMPTY;
WRITE←RECORD(CONST←REC); NOCODE := FALSE
END
END (*WITH FCSP↑*)
END (*COPYCSP*);
PROCEDURE COPYSTP(FSP:STP); FORWARD;
PROCEDURE COPYCTP(FCP:CTP);
BEGIN
IF FCP <> NIL
THEN
WITH FCP↑ DO
IF RUN1 AND (SELFCTP=NIL) OR NOT RUN1 AND NOCODE
THEN
BEGIN
LSIZE := IDRECSIZE[KLASS];
IF RUN1
THEN
WITH ICCHANGE DO
BEGIN
ICVAL := IC;
SELFCTP := ICCTP; NOCODE := TRUE;
IC := IC + LSIZE
END (* RUN1 *)
ELSE
WITH RECORDCHANGE DO
BEGIN
RELARRAY := RELEMPTY;
IDENTREC := FCP↑;
WITH IDENTREC DO
BEGIN
IF LLINK<>NIL
THEN LLINK:=LLINK↑.SELFCTP;
IF RLINK<>NIL
THEN RLINK:=RLINK↑.SELFCTP;
RELARRAY[3] := BOTH;
IF NEXT <>NIL
THEN NEXT := NEXT↑.SELFCTP;
RELARRAY[4] := BOTH;
IF IDTYPE <> NIL
THEN
BEGIN
CASE KLASS OF
KONST:
IF IDTYPE↑.FORM > POINTER
THEN
BEGIN
VALUES.VALP := VALUES.VALP↑.SELFCSP;
RELARRAY[6] := RIGHT
END
ELSE
IF IDTYPE = REALPTR
THEN
BEGIN
CHANGE.WREAL := VALUES.VALP↑.RVAL;
VALUES.IVAL := CHANGE.WKONST
END;
VARS:
BEGIN
IF VLEV < 2
THEN RELARRAY[6] := RIGHT;
WITH FCP↑ DO
IF (IDTYPE↑.FORM = FILES) AND (VLEV = 0) AND EXTERNAL
THEN VADDR := ORD(SELFCTP) + 5
END
END (*CASE*);
IDTYPE := IDTYPE↑.SELFSTP
END
END;
WRITE←RECORD(IDENT←REC); NOCODE := FALSE
END (* RUN2 *);
COPYCTP(LLINK);
COPYCTP(RLINK);
COPYSTP(IDTYPE);
COPYCTP(NEXT);
IF (KLASS = KONST) AND (IDTYPE <> NIL)
THEN
IF IDTYPE↑.FORM > POINTER
THEN COPYCSP(VALUES.VALP)
END (*WITH FCP↑*)
END (*COPYCTP*);
PROCEDURE COPYSTP;
BEGIN
IF FSP <> NIL
THEN
WITH FSP↑ DO
BEGIN
IF RUN1 AND (SELFSTP = NIL) OR NOT RUN1 AND NOCODE
THEN
BEGIN
LSIZE := STRECSIZE[FORM];
IF RUN1
THEN
WITH ICCHANGE DO
BEGIN
NOCODE:=TRUE;
ICVAL := IC; SELFSTP := ICSTP;
IC := IC + LSIZE
END (* RUN1 *)
ELSE
WITH RECORDCHANGE DO
BEGIN
RELARRAY := RELEMPTY; RELARRAY[2] := RIGHT;
STRUCTREC := FSP↑;
WITH STRUCTREC DO
CASE FORM OF
SCALAR:
IF SCALKIND = DECLARED
THEN
IF FCONST<>NIL
THEN FCONST:=FCONST↑.SELFCTP;
SUBRANGE:
RANGETYPE:=RANGETYPE↑.SELFSTP;
POINTER:
IF ELTYPE <> NIL
THEN ELTYPE := ELTYPE↑.SELFSTP;
POWER:
ELSET := ELSET↑.SELFSTP;
ARRAYS:
BEGIN
AELTYPE := AELTYPE↑.SELFSTP;
INXTYPE := INXTYPE↑.SELFSTP; RELARRAY[3] := BOTH
END;
RECORDS:
BEGIN
IF FSTFLD <> NIL
THEN FSTFLD := FSTFLD↑.SELFCTP;
IF RECVAR <> NIL
THEN
BEGIN
RECVAR := RECVAR↑.SELFSTP; RELARRAY[3] := LEFT
END
END;
FILES:
FILTYPE := FILTYPE↑.SELFSTP;
TAGFWITHID,
TAGFWITHOUTID:
BEGIN
FSTVAR := FSTVAR↑.SELFSTP;
IF FORM = TAGFWITHID
THEN TAGFIELDP := TAGFIELDP↑.SELFCTP;
RELARRAY[3] := LEFT
END;
VARIANT:
BEGIN
IF SUBVAR <> NIL
THEN SUBVAR := SUBVAR↑.SELFSTP;
IF FIRSTFIELD <> NIL
THEN FIRSTFIELD := FIRSTFIELD↑.SELFCTP;
RELARRAY[3] := BOTH;
IF NXTVAR <> NIL
THEN NXTVAR := NXTVAR↑.SELFSTP
END
END (*CASE*);
WRITE←RECORD(STRUCT←REC); NOCODE := FALSE
END (*RUN 2*);
CASE FORM OF
SCALAR:
IF SCALKIND = DECLARED
THEN COPYCTP(FCONST);
SUBRANGE:
COPYSTP(RANGETYPE);
POINTER:
COPYSTP(ELTYPE);
POWER:
COPYSTP(ELSET);
ARRAYS:
BEGIN
COPYSTP(AELTYPE);
COPYSTP(INXTYPE)
END;
RECORDS:
BEGIN
COPYCTP(FSTFLD);
COPYSTP(RECVAR)
END;
FILES:
COPYSTP(FILTYPE);
TAGFWITHID,
TAGFWITHOUTID:
BEGIN
COPYSTP(FSTVAR);
IF FORM = TAGFWITHID
THEN COPYCTP(TAGFIELDP)
END;
VARIANT:
BEGIN
COPYSTP(NXTVAR);
COPYSTP(SUBVAR);
COPYCTP(FIRSTFIELD)
END
END (*CASE*)
END ;
END (* WITH FSP↑ *)
END (*COPYSTP*);
BEGIN (*CODE←FOR←DEBUG*)
FOR I := 1 TO MAXSIZE DO RELEMPTY[I] := NO;
IF DEBUG←SWITCH
THEN
BEGIN
WRITE←FIRST←LINE; LCP := DISPLAY[TOP].FNAME;
IF LEVEL = 1
THEN
BEGIN
DEBUGENTRY.GLOBALIDTREE := IC;
IF LCP<>NIL
THEN
IF LCP↑.SELFCTP <> NIL
THEN DEBUGENTRY.GLOBALIDTREE := ORD(LCP↑.SELFCTP)
END;
FOR RUN1 := TRUE DOWNTO FALSE DO COPYCTP(LCP);
LNLK := GLOBNEWLINK;
WHILE LNLK <> NIL DO
WITH LNLK↑ DO
BEGIN
IF REFTYPE↑.SELFSTP = NIL
THEN FOR RUN1 := TRUE DOWNTO FALSE DO COPYSTP(REFTYPE);
LNLK := NEXT
END;
IF LEVEL = 1
THEN
BEGIN
DEBUGENTRY.STANDARDIDTREE := IC;
FOR RUN1 := TRUE DOWNTO FALSE DO COPYCTP(DISPLAY[0].FNAME)
END;
END (*DEBUG←SWITCH*);
IF LEVEL = 1
THEN
BEGIN
WITH DEBUGENTRY DO
BEGIN
NEWPAGER; LASTPAGEELEM := PAGER;
INTPOINT := INTPTR↑. SELFSTP;
REALPOINT := REALPTR↑.SELFSTP;
BOOLPOINT := BOOLPTR↑.SELFSTP;
CHARPOINT := ASCIIPTR↑.SELFSTP
END;
PAGEHEADADR := IC;
FOR I:=1 TO DEBENTRY←SIZE DO RELARRAY[I] := RIGHT;
RECORDCHANGE.DEBUGREC := DEBUGENTRY;
IC := IC + DEBENTRY←SIZE;
LSIZE := DEBENTRY←SIZE;
WRITE←RECORD(DEBUG←REC);
HIGHEST←CODE := IC;
IF LIST←CODE
THEN
BEGIN
WRITELN(LIST); WRITE(LIST,DEBUG←SAVE:6:O,'''',' ':13)
END;
WRITE←BLOCK←START(RIGHT,DEBUG←SAVE,ITEM←1);
WRITE←WORD(NO,0);
WRITE←PAIR(NO,260740B,0);
WRITE←PAIR(RIGHT,0,PAGEHEADADR);
FOR I := 1 TO 3 DO WRITE←WORD(NO,0);
WRITE←PAIR(NO,260740B,0);
WRITE←PAIR(RIGHT,0,NAME←ADDRESS)
END (*LEVEL=1*)
END (*DEBUG*);
PROCEDURE CODE←FOR←CONTROL;
VAR
I,J: INTEGER; INLEVEL: BOOLEAN;
CHECKER: CTP;
BEGIN
(*CODE←FOR←CONTROL*)
CASE WRITE←FLAG OF
WRITE←INTERNALS:
BEGIN
WRITE←HEADER('LINK-CHAIN(S) ');
WRITE←BLOCK←START(NO,0,ITEM←10);
WHILE GLOBNEWLINK <> NIL DO
WITH GLOBNEWLINK↑ DO
BEGIN
WRITE←PAIR( BOTH , REFADR , ORD( REFTYPE↑.SELFSTP ));
GLOBNEWLINK := NEXT
END;
INLEVEL := TRUE;
CHECKER := LOCALPFPTR;
WHILE (CHECKER <> NIL) AND INLEVEL DO
WITH CHECKER↑ DO
IF PFLEV = LEVEL
THEN
BEGIN
IF PFADDR <> 0
THEN FOR I := 0 TO MAXLEVEL DO
IF LINKCHAIN[I] <> 0
THEN WRITE←PAIR(BOTH,LINKCHAIN[I],PFADDR-I);
CHECKER:= PFCHAIN
END
ELSE INLEVEL := FALSE;
IF LEVEL > 1
THEN LOCALPFPTR := CHECKER;
WHILE FIRSTKONST <> NIL DO
WITH FIRSTKONST↑, CONSTPTR↑ DO
BEGIN
WRITE←PAIR(BOTH,ADDR,KADDR);
IF (CCLASS IN [PSET,STRD]) AND DOUBLE←CHAIN
THEN WRITE←PAIR(BOTH,ADDR-1,KADDR+1);
FIRSTKONST:= NEXTKONST
END;
INLEVEL := TRUE;
WHILE (DECLSCALPTR <> NIL) AND INLEVEL DO
WITH DECLSCALPTR↑ DO
IF (LEVEL = TLEV) OR ((LEVEL = 1) AND (TLEV = 0))
THEN
BEGIN
IF REQUEST
THEN WRITE←PAIR(BOTH,VECTORCHAIN,VECTORADDR);
DECLSCALPTR := NEXTSCALAR
END
ELSE INLEVEL := FALSE;
INLEVEL := TRUE;
WHILE (LAST←LABEL <> NIL) AND INLEVEL DO
WITH LAST←LABEL↑ DO
IF SCOPE = LEVEL
THEN
BEGIN
IF GOTO←CHAIN <> 0
THEN
IF LABEL←ADDRESS = 0
THEN ERROR←WITH←TEXT(214,NAME)
ELSE WRITE←PAIR(BOTH,GOTO←CHAIN,LABEL←ADDRESS);
LAST←LABEL := NEXT
END
ELSE INLEVEL := FALSE;
IF LEVEL = 1
THEN
BEGIN
J := 0;
FOR I := 1 TO JUMPER DO
BEGIN
IF JUMP←TABLE[I] <> 0
THEN
BEGIN
WRITE←PAIR(BOTH,JUMP←TABLE[I],JUMP←ADDRESS + J);
WRITE←PAIR(BOTH,JUMP←TABLE[I] + 1, JUMP←ADDRESS + J + 1);
J := J + 2
END
END
END
END;
WRITE←END:
BEGIN
WRITE←HEADER('HIGHSEG-BREAK ');
WRITE←BLOCK←START(NO,0,ITEM←5);
WRITE←PAIR(RIGHT,0,HIGHEST←CODE);
WRITE←HEADER('LOWSEG-BREAK ');
LIC := 0;
WRITE←PAIR(RIGHT,0,LCMAIN); PUT←RELOCATABLE←CODE
END;
WRITE←START:
IF NOT EXTERNAL
THEN
BEGIN
WRITE←HEADER('START-ADDRESS ');
WRITE←BLOCK←START(NO,0,ITEM←7);
WRITE←PAIR(RIGHT,0,START←ADDRESS)
END;
WRITE←ENTRY:
IF EXTERNAL
THEN
BEGIN
WRITE←BLOCK←START(NO,0,ITEM←4);
FOR I := 2 TO ENTRIES DO
WRITE←IDENTIFIER(ENTRY←SYMBOL,ENTRY[I])
END;
WRITE←NAME:
BEGIN
WRITE←BLOCK←START(NO,0,ITEM←6);
WRITE←IDENTIFIER(ENTRY←SYMBOL,PROGRAMNAME)
END;
WRITE←HISEG:
BEGIN
LLIST←CODE := FALSE;
WRITE←BLOCK←START(NO,0,ITEM←3);
WRITE←PAIR(NO,400000B,400000B)
END
END (*CASE*)
END (*CODE←FOR←CONTROL*) ;
PROCEDURE CODE←FOR←SYMBOLS;
VAR
SAVE←LIST←CODE: BOOLEAN;
SWITCHFLAG: FLAGRANGE; CHECKER: CTP;
BEGIN
(*CODE←FOR←SYMBOLS*)
WRITE←HEADER('ENTRY-POINT(S) ');
WRITE←BLOCK←START(NO,0,ITEM←2);
IF NOT EXTERNAL
THEN
BEGIN
WRITE←IDENTIFIER(LOCAL←SYMBOL,PROGRAMNAME);
WRITE←PAIR(RIGHT,0,START←ADDRESS)
END
ELSE
BEGIN
CHECKER := LOCALPFPTR;
WHILE CHECKER <> NIL DO
WITH CHECKER↑ DO
BEGIN
IF PFADDR <> 0
THEN
BEGIN
WRITE←IDENTIFIER(LOCAL←SYMBOL,NAME);
WRITE←PAIR(RIGHT,0,PFADDR)
END;
CHECKER:= PFCHAIN
END;
SAVE←LIST←CODE := LIST←CODE; LIST←CODE := FALSE;
CHECKER := LOCALPFPTR;
WHILE CHECKER <> NIL DO
WITH CHECKER↑ DO
BEGIN
IF PFADDR <> 0
THEN
BEGIN
WRITE←IDENTIFIER(GLOBAL←SYMBOL,NAME);
WRITE←PAIR(RIGHT,0,PFADDR)
END;
CHECKER := PFCHAIN
END;
LIST←CODE := SAVE←LIST←CODE
END;
IF NOT EXTERNAL
THEN
BEGIN
SWITCHFLAG:= GLOBAL←SYMBOL; WRITE←HEADER('ENTRY-SYMBOL(S) ')
END
ELSE
BEGIN
SWITCHFLAG:= EXTERN←SYMBOL; WRITE←HEADER('EXTERN-SYMBOL(S) ')
END;
FILEPTR := SFILEPTR;
WHILE FILEPTR <> NIL DO
WITH FILEPTR↑, FILEIDENT↑ DO
BEGIN
IF VADDR <> 0
THEN
BEGIN
WRITE←IDENTIFIER(SWITCHFLAG,NAME);
WRITE←PAIR(RIGHT,0,VADDR)
END;
FILEPTR:= NEXTFTP
END;
IF NOT EXTERNAL
THEN WRITE←HEADER('EXTERN-SYMBOL(S) ');
CHECKER:= EXTERNPFPTR;
WHILE CHECKER <> NIL DO
WITH CHECKER↑ DO
BEGIN
IF LINKCHAIN[0] <> 0
THEN
BEGIN
IF PFLEV = 0
THEN WRITE←IDENTIFIER(EXTERN←SYMBOL,EXTERNALNAME)
ELSE WRITE←IDENTIFIER(EXTERN←SYMBOL,NAME);
WRITE←PAIR(RIGHT,0,LINKCHAIN[0])
END;
CHECKER:= PFCHAIN
END;
FOR SUPPORT←INDEX := FIRST(SUPPORT←INDEX) TO LAST(SUPPORT←INDEX) DO
IF RUNTIME←SUPPORT.LINK[SUPPORT←INDEX] <> 0
THEN
BEGIN
WRITE←IDENTIFIER(EXTERN←SYMBOL,RUNTIME←SUPPORT.NAME[SUPPORT←INDEX]);
WRITE←PAIR(RIGHT,0,RUNTIME←SUPPORT.LINK[SUPPORT←INDEX])
END;
IF DEBUG
THEN
BEGIN
WRITE←IDENTIFIER(EXTERN←SYMBOL,RUNTIME←SUPPORT.NAME[ENTERDEBUG]);
WRITE←PAIR(RIGHT,0,DEBUG←STOP);
WRITE←IDENTIFIER(EXTERN←SYMBOL,RUNTIME←SUPPORT.NAME[INITIALIZEDEBUG]);
WRITE←PAIR(RIGHT,0,DEBUG←INITIALIZATION)
END;
IF NOT (DEBUG OR EXTERNAL)
THEN
BEGIN
WRITE←IDENTIFIER(EXTERN←SYMBOL,RUNTIME←SUPPORT.NAME[OVERFLOW]);
WRITE←PAIR(NO,0,JBAPR)
END
END (*CODE←FOR←SYMBOLS*) ;
PROCEDURE CODE←FOR←LIBRARIES;
VAR
I, J, L: INTEGER;
BEGIN
(*CODE←FOR←LIBRARIES*)
WRITE←HEADER('LINK-LIBRARIE(S) ');
WRITE←BLOCK←START(NO,0,ITEM←17);
FOR L := 1 TO 2 DO
BEGIN
FOR I := 1 TO LIBRARY←INDEX DO
WITH LIBRARY[LIBRARY←ORDER[I]] DO
IF CALLED
THEN WITH CHANGE DO
BEGIN
FOR J := 1 TO 6 DO WSIXBIT[J] := ORD(NAME[J]) - 40B;
WRITE←IDENTIFIER(SIXBIT←SYMBOL,NAME);
WRITE←PAIR(NO,PROJNR,PROGNR);
FOR J := 1 TO 6 DO WSIXBIT[J] := ORD(DEVICE[J]) - 40B;
WRITE←IDENTIFIER(SIXBIT←SYMBOL,DEVICE); LIC := LIC + 1
END;
I := 1;
FOR LANGUAGE←INDEX := FORTRANSY DOWNTO PASCALSY DO
WITH LIBRARY[LANGUAGE←INDEX] DO
BEGIN
CALLED := (NOT CHAINED AND CALLED) OR ((LANGUAGE←INDEX = PASCALSY) AND NOT CALLED);
LIBRARY←ORDER[I] := LANGUAGE←INDEX; I := I + 1
END;
LIBRARY←INDEX := 2
END
END (*CODE←FOR←LIBRARIES*);
BEGIN
(*WRITE←MACHINE←CODE*)
PUT←CODE←ARRAY := FALSE;
SPACE←W := 2; SPACE←C := 0;
IF ERROR←FLAG
THEN
BEGIN
LASTBTP := NIL;
DECLSCALPTR := NIL
END
ELSE
BEGIN
LLIST←CODE := LIST←CODE;
CASE WRITE←FLAG OF
WRITE←FILEBLOCKS:
CODE←FOR←FILEBLOCKS;
WRITE←GLOBALS :
CODE←FOR←GLOBALS;
WRITE←CODE :
CODE←FOR←INSTRUCTIONS;
WRITE←DEBUG :
CODE←FOR←DEBUG;
WRITE←SYMBOLS :
CODE←FOR←SYMBOLS;
WRITE←INTERNALS,
WRITE←ENTRY,
WRITE←END,
WRITE←START,
WRITE←HISEG,
WRITE←NAME :
CODE←FOR←CONTROL;
WRITE←LIBRARY :
CODE←FOR←LIBRARIES
END (*CASE*);
IF LIST←CODE AND (WRITE←FLAG > WRITE←HISEG)
THEN WRITELN(LIST)
END (*IF ERROR←FLAG*)
END (*WRITE←MACHINE←CODE*);
PROCEDURE STATEMENT(FSYS,STATENDS: SETOFSYS);
TYPE
VALUEKIND = (ONREGC,ONFIXEDREGC,TRUEJMP,FALSEJMP);
VAR
LCP: CTP; J: INTEGER;
PROCEDURE EXPRESSION(FSYS: SETOFSYS; FVALUE:VALUEKIND); FORWARD;
PROCEDURE MAKEREAL(VAR FATTR: ATTR);
BEGIN
IF FATTR.TYPTR=INTPTR
THEN
BEGIN
LOAD(FATTR);
MACRO3(551B(*HRRZI*),REG1,FATTR.REG);
SUPPORT(CONVERTINTEGERTOREAL);
FATTR.TYPTR := REALPTR
END;
IF GATTR.TYPTR=INTPTR
THEN MAKEREAL(GATTR)
END;
PROCEDURE SELECTOR(FSYS: SETOFSYS; FCP: CTP);
VAR
LATTR: ATTR; LCP: CTP; LSP: STP;
LMIN,LMAX,INDEXVALUE,INDEXOFFSET: INTEGER;
OLDIC: ACRANGE;
BYTES: BITRANGE;
PROCEDURE SUBLOWBOUND;
BEGIN
IF LMIN > 0
THEN MACRO3(275B(*SUBI*),REGC,LMIN)
ELSE
IF LMIN < 0
THEN MACRO3(271B(*ADDI*),REGC,-LMIN);
IF RUNTIME←CHECK
THEN
BEGIN
MACRO3(301B(*CAIL*),REGC,0);
MACRO3(303B(*CAILE*),REGC,LMAX-LMIN);
SUPPORT(INDEXERROR)
END
END;
BEGIN
WITH FCP↑, GATTR DO
BEGIN
TYPTR := IDTYPE; KIND := VARBL; PACKFG := NOTPACK; VCLASS := KLASS;
CASE KLASS OF
VARS:
BEGIN
VLEVEL := VLEV; DPLMT := VADDR; INDEXR := 0;
IF VLEV > 1
THEN VRELBYTE:= NO
ELSE VRELBYTE:= RIGHT;
IF IDTYPE↑.FORM = FILES
THEN LAST←FILE:= FCP
ELSE LAST←FILE:= NIL;
INDBIT := ORD(VKIND)
END;
FIELD:
WITH DISPLAY[DISX] DO
IF OCCUR = CREC
THEN
BEGIN
VLEVEL := CLEV; PACKFG := PACKF; VRELBYTE := CRELBYTE;
IF PACKFG = PACKK
THEN
BEGIN
VBYTE := FLDBYTE;
DPLMT := CDSPL
END
ELSE DPLMT := CDSPL+FLDADDR;
INDEXR := CINDR; INDBIT:=CINDB
END
ELSE ERROR(171);
FUNC:
IF PFDECKIND = STANDARD
THEN ERROR(502)
ELSE
IF PFLEV = 0
THEN ERROR(502) (*EXTERNAL FUNCTION*)
ELSE
IF PFKIND = FORMAL (*FORMAL FUNCTION*)
THEN ERROR(456)
ELSE
BEGIN
VLEVEL := PFLEV+1;
VRELBYTE := NO;
IF NOT ACTIVATED
THEN ERROR(509);
DPLMT := 1; (* THE RELATIVE ADDRESS OF THE FUNCTION'S RESULT *)
INDEXR :=0;
INDBIT :=0
END
END (*CASE*)
END (*WITH*);
IFERRSKIP(166,SELECTSYS + FSYS);
WHILE SY IN SELECTSYS DO
BEGIN
(*[*)
IF SY = LBRACK
THEN
BEGIN
IF GATTR.INDBIT = 1
THEN GET←PARAMETER←ADDRESS;
OLDIC := GATTR.INDEXR;
INDEXOFFSET := 0 ;
LOOP
LATTR := GATTR; INDEXVALUE := 0 ;
WITH LATTR DO
IF TYPTR <> NIL
THEN
BEGIN
IF TYPTR↑.FORM <> ARRAYS
THEN
BEGIN
ERROR(307); TYPTR := NIL
END;
LSP := TYPTR
END;
INSYMBOL;
EXPRESSION(FSYS + [COMMA,RBRACK],ONREGC);
IF GATTR.KIND<>CST
THEN LOAD(GATTR)
ELSE INDEXVALUE := GATTR.CVAL.IVAL ;
IF GATTR.TYPTR <> NIL
THEN
IF GATTR.TYPTR↑.FORM <> SCALAR
THEN ERROR(403);
IF LATTR.TYPTR <> NIL
THEN WITH LATTR,TYPTR↑ DO
BEGIN
IF COMPTYPES(INXTYPE,GATTR.TYPTR)
THEN
BEGIN
IF INXTYPE <> NIL
THEN
BEGIN
GETBOUNDS(INXTYPE,LMIN,LMAX);
IF GATTR.KIND = CST
THEN
IF (INDEXVALUE < LMIN) OR (INDEXVALUE > LMAX)
THEN ERROR(263)
END
END
ELSE ERROR(457);
TYPTR := AELTYPE
END
EXIT IF SY <> COMMA;
WITH LATTR DO
IF TYPTR<>NIL
THEN
IF GATTR.KIND = CST
THEN DPLMT := DPLMT + ( INDEXVALUE - LMIN ) * TYPTR↑.SIZE
ELSE
BEGIN
SUBLOWBOUND;
IF TYPTR↑.SIZE > 1
THEN MACRO3(221B(*IMULI*),REGC,TYPTR↑.SIZE);
IF OLDIC = 0
THEN OLDIC := REGC
ELSE
IF OLDIC > REGCMAX
THEN
BEGIN
MACRO3(270B(*ADD*),REGC,OLDIC);
OLDIC := REGC
END
ELSE
BEGIN
MACRO3(270B(*ADD*),OLDIC,REGC) ;
REGC := REGC - 1
END;
INDEXR := OLDIC
END ;
GATTR := LATTR
END (*LOOP*);
WITH LATTR DO
IF TYPTR <> NIL
THEN
BEGIN
IF GATTR.KIND = CST
THEN INDEXOFFSET := ( INDEXVALUE - LMIN ) * TYPTR↑.SIZE
ELSE
BEGIN
IF (TYPTR↑.SIZE > 1) OR RUNTIME←CHECK
THEN SUBLOWBOUND
ELSE INDEXOFFSET := -LMIN;
IF TYPTR↑.SIZE > 1
THEN MACRO3(221B(*IMULI*),REGC,TYPTR↑.SIZE);
INDEXR := REGC
END ;
IF LSP↑.ARRAYPF
THEN
BEGIN
BYTES := BITMAX DIV LSP↑.AELTYPE↑.BITSIZE;
IF GATTR.KIND = CST
THEN
BEGIN
BPADDR := INDEXOFFSET MOD BYTES + LSP↑.ARRAYBPADDR + 1;
INDEXR := OLDIC;
INDEXOFFSET := INDEXOFFSET DIV BYTES
END
ELSE
BEGIN
INCREMENT←REGC;
IF INDEXR=OLDIC
THEN
BEGIN
INCREMENT←REGC; INDEXR := 0
END;
MACRO4(571B(*HRREI*),REGC,INDEXR,INDEXOFFSET);
INCREMENT←REGC;
REGC := REGC-1; INDEXOFFSET := 0;
MACRO3(231B(*IDIVI*),REGC,BYTES);
MACRO4R(200B(*MOVE*),REGC-1,REGC+1,LSP↑.ARRAYBPADDR+1);
BPADDR := REGC-1; INDEXR := REGC
END;
PACKFG := PACKK
END (*ARRAYPACKFLAG*);
DPLMT := DPLMT + INDEXOFFSET ;
KIND := VARBL; VCLASS := VARS;
IF ( OLDIC <> INDEXR ) AND ( OLDIC <> 0 )
THEN
BEGIN
IF OLDIC > REGCMAX
THEN MACRO3(270B(*ADD*),INDEXR,OLDIC)
ELSE
BEGIN
MACRO3(270B(*ADD*),OLDIC,INDEXR);
REGC := REGC - 1;
INDEXR := OLDIC
END
END
END (*WITH.. IF TYPTR <> NIL*) ;
GATTR := LATTR ;
IF SY = RBRACK
THEN INSYMBOL
ELSE ERROR(155)
END (*IF SY = LBRACK*)
ELSE
(*.*)
IF SY = PERIOD
THEN
BEGIN
WITH GATTR DO
BEGIN
IF TYPTR <> NIL
THEN
IF TYPTR↑.FORM <> RECORDS
THEN
BEGIN
ERROR(308); TYPTR := NIL
END;
IF INDBIT=1
THEN GET←PARAMETER←ADDRESS;
INSYMBOL;
IF SY = IDENT
THEN
BEGIN
IF TYPTR <> NIL
THEN
BEGIN
SEARCHSECTION(TYPTR↑.FSTFLD,LCP);
IF LCP = NIL
THEN
BEGIN
ERROR(309); TYPTR := NIL
END
ELSE WITH LCP↑ DO
BEGIN
TYPTR := IDTYPE; PACKFG := PACKF;
IF PACKFG = PACKK
THEN
BEGIN
VCLASS := FIELD; VBYTE := FLDBYTE
END
ELSE DPLMT := DPLMT + FLDADDR
END
END;
INSYMBOL
END (*SY = IDENT*)
ELSE ERROR(209)
END (*WITH GATTR*)
END (*IF SY = PERIOD*)
ELSE
(*↑*)
BEGIN
IF GATTR.TYPTR <> NIL
THEN WITH GATTR,TYPTR↑ DO
IF FORM IN [POINTER,FILES]
THEN
BEGIN
IF FORM = POINTER
THEN TYPTR := ELTYPE
ELSE TYPTR := FILTYPE;
IF TYPTR <> NIL
THEN
BEGIN
LOADNOPTR := FALSE;
LOAD(GATTR); LOADNOPTR := TRUE;
WITH FCP↑ DO
IF (IDTYPE↑.FORM = FILES) AND (VLEV = 0) AND EXTERNAL
THEN
BEGIN
VADDR:= IC-1; CODE←REFERENCE↑[CIX] := EXTERNREF
END;
INDEXR := REG; DPLMT := 0; INDBIT:=0; PACKFG := NOTPACK; KIND := VARBL;
VRELBYTE:= NO; VCLASS := VARS
END
END
ELSE ERROR(407);
INSYMBOL
END;
IFERRSKIP(166,FSYS + SELECTSYS)
END (*WHILE*);
WITH GATTR DO
IF TYPTR<>NIL
THEN
IF TYPTR↑.SIZE = 2
THEN
BEGIN
IF INDBIT = 1
THEN GET←PARAMETER←ADDRESS;
IF (INDEXR>REGIN) AND (INDEXR<=REGCMAX)
THEN INCREMENT←REGC
END
END (*SELECTOR*) ;
PROCEDURE CALL(FSYS: SETOFSYS; FCP: CTP);
LABEL
666;
VAR
LKEY: INTEGER;
LCLASS: IDCLASS;
LSUPPORT: SUPPORTS;
TTY←MESSAGE, NOLOAD, LFOLLOWERROR, NO←RIGHT←PARENT, BUFFER←VARIABLE : BOOLEAN;
PROCEDURE GETFILENAME(DEFAULT←NAME:ALFA; FOLLOWSYS: SETOFSYS);
VAR
LCP : CTP ; LVLEV: LEVRANGE; DEFAULT,DEFAULT←TTY : BOOLEAN ;
LSY: SYMBOL; LID: ALFA;
BEGIN
DEFAULT := TRUE ; DEFAULT←TTY := FALSE; NO←RIGHT←PARENT := TRUE;
BUFFER←VARIABLE := FALSE;
IF SY = LPARENT
THEN
BEGIN
NO←RIGHT←PARENT := FALSE;
INSYMBOL ;
IF SY = IDENT
THEN
BEGIN
SEARCHID([KONST,VARS,FIELD,PROC,FUNC],LCP);
IF LCP <> NIL
THEN
WITH LCP↑,IDTYPE↑ DO
IF IDTYPE <> NIL
THEN
BEGIN
IF FORM = FILES
THEN
BEGIN
IF ARROW IN FOLLOWSYS
THEN INSYMBOL;
IF SY <> ARROW
THEN
BEGIN
DEFAULT := FALSE;
IF
(((LKEY IN [2,4,7,8,10,11,17,19,28]) AND (LCLASS = PROC)) OR
((LKEY = 11) AND (LCLASS = FUNC))) AND
(FILE←FORM <> TEXT←FILE)
THEN ERROR(366)
END
ELSE BUFFER←VARIABLE := TRUE
END;
IF KLASS = VARS
THEN LVLEV := VLEV
ELSE LVLEV := 1
END;
IF (LVLEV = 0) AND
(ID = 'TTY ') AND
((DEFAULT←NAME = 'OUTPUT ') OR (DEFAULT←NAME = 'TTYOUTPUT ')) AND
NOT BUFFER←VARIABLE
THEN
BEGIN
DEFAULT := TRUE; DEFAULT←TTY := TRUE;
DEFAULT←NAME := 'TTYOUTPUT '
END
END (*SY = IDENT*)
END (*SY = LPARENT*);
IF NO←RIGHT←PARENT
AND (SY IN (FACBEGSYS + [ADDOP])) AND NOT ( (LCLASS=FUNC) AND (LKEY IN [10,11]) )
THEN ERROR(156);
TTYREAD := (NOT DEFAULT AND (ID = 'TTY ')) OR
(DEFAULT AND (DEFAULT←NAME = 'TTY ')) OR TTYREAD;
IF DEFAULT
THEN
BEGIN
LID := ID; ID := DEFAULT←NAME;
SEARCHID([VARS],LCP);
IF LCP↑.IDTYPE↑.FORM <> FILES
THEN SEARCHSECTION(DISPLAY[0].FNAME,LCP);
ID := LID
END ;
LSY := SY; SY := COMMA; LFOLLOWERROR := FOLLOWERROR;
SELECTOR(FSYS + [COMMA,RPARENT],LCP) ;
SY := LSY; FOLLOWERROR := LFOLLOWERROR;
IF NOLOAD
THEN
WITH GATTR DO
BEGIN
IF (INDBIT <> 0) OR ((LCP↑.VLEV = 0) AND EXTERNAL)
THEN LOAD←ADDRESS;
CASE LKEY OF
10:
DPLMT := DPLMT + FILEOF; (*EOF*)
11:
DPLMT := DPLMT + FILEOL; (*EOLN*)
17:
DPLMT := DPLMT + FILLNR (*GETLINENR*)
END
END
ELSE LOAD←ADDRESS;
IF BUFFER←VARIABLE
THEN
BEGIN
SEARCHID([VARS],LCP);
SELECTOR(FSYS + (FOLLOWSYS-[ARROW]),LCP)
END;
IF NOT DEFAULT OR DEFAULT←TTY
THEN
BEGIN
IF NOT (ARROW IN FOLLOWSYS)
THEN INSYMBOL;
IF NOT (SY IN FOLLOWSYS-[ARROW])
THEN
ERROR(458)
ELSE
IF SY = COMMA
THEN INSYMBOL
END
END (*GETFILENAME*) ;
PROCEDURE VARIABLE(FSYS: SETOFSYS);
VAR
LCP: CTP;
BEGIN
IF SY = IDENT
THEN
BEGIN
SEARCHID([VARS,FIELD],LCP); INSYMBOL
END
ELSE
BEGIN
ERROR(209); LCP := UVARPTR
END;
SELECTOR(FSYS,LCP)
END (*VARIABLE*) ;
PROCEDURE GETPUTRESETREWRITE;
VAR
DEFAULT : ARRAY [1..4] OF BOOLEAN;
I : INTEGER;
LATTR: ATTR;
PROCEDURE GETSTRINGADDRESS(LENGTH: INTEGER) ;
VAR
LATTR: ATTR;
BEGIN
IF SY <> RPARENT
THEN
BEGIN
EXPRESSION(FSYS + [COMMA],ONFIXEDREGC);
WITH GATTR DO
IF STRING(TYPTR)
THEN
WITH TYPTR↑ DO
IF ARRAYPF AND (SIZE=2) AND (INXTYPE↑.VMAX.IVAL-INXTYPE↑.VMIN.IVAL+1 = LENGTH)
THEN
BEGIN
DEFAULT[I] := FALSE; LOAD←ADDRESS
END
ELSE ERROR(458)
ELSE ERROR(458)
END
END (*GETSTRINGADDRESS*);
BEGIN
CASE LKEY OF
1,2 :
GETFILENAME('INPUT ',[RPARENT]);
3,4 :
GETFILENAME('OUTPUT ',[RPARENT]);
5 :
GETFILENAME('INPUT ',[COMMA,RPARENT]);
6 :
GETFILENAME('OUTPUT ',[COMMA,RPARENT])
END;
IF LKEY IN [5,6]
THEN
BEGIN
FOR I := 1 TO 4 DO DEFAULT[I] := TRUE;
I := 1;
GETSTRINGADDRESS(9) (* OF FILENAME *) ;
WHILE (I<3) AND NOT DEFAULT[1] AND (SY=COMMA) DO
BEGIN
I := I + 1;
INSYMBOL; EXPRESSION(FSYS + [COMMA],ONFIXEDREGC);
IF GATTR.TYPTR <> NIL
THEN
IF COMPTYPES(GATTR.TYPTR,INTPTR)
THEN
BEGIN
LOAD(GATTR); DEFAULT[I] := FALSE
END
ELSE ERROR(458)
END;
IF NOT DEFAULT[3]
THEN
BEGIN
I := I+1;
IF SY = COMMA
THEN INSYMBOL;
GETSTRINGADDRESS(6) (* OF DEVICE NAME *)
END;
FOR I := 1 TO 4 DO
IF DEFAULT[I]
THEN
BEGIN
INCREMENT←REGC;
MACRO2(400B(*SETZ*),REGC)
END
END;
CASE LKEY OF
1:
BEGIN
LSUPPORT := GETFILE;
IF GATTR.TYPTR <> NIL
THEN
IF GATTR.TYPTR↑.FILE←FORM = TEXT←FILE
THEN LSUPPORT := GETCHARACTER
END;
2:
IF COMPTYPES(GATTR.TYPTR,TEXTPTR)
THEN LSUPPORT := GETLINE
ELSE ERROR(366) ;
3:
LSUPPORT := PUTFILE ;
4:
IF COMPTYPES(GATTR.TYPTR,TEXTPTR)
THEN LSUPPORT := PUTLINE
ELSE ERROR(366) ;
5:
LSUPPORT := RESETFILE ;
6:
LSUPPORT := REWRITEFILE
END ;
SUPPORT(LSUPPORT);
IF (LKEY = 1) AND (GATTR.TYPTR <> NIL) AND RUNTIME←CHECK
THEN
IF GATTR.TYPTR↑.FILTYPE <> NIL
THEN
WITH GATTR.TYPTR↑.FILTYPE↑ DO
IF (FORM = SUBRANGE) AND (GATTR.TYPTR↑.FILE←FORM <> TEXT←FILE)
THEN
BEGIN
INCREMENT←REGC; MACRO4(200B(*MOVE*),REGC,REGC-1,FILCMP);
LATTR.KIND := CST; LATTR.TYPTR := RANGETYPE;
LATTR.CVAL := VMAX; GENERATE←CODE(317B(*CAMG*),REGC,LATTR);
LATTR.CVAL := VMIN; GENERATE←CODE(315B(*CAMGE*),REGC,LATTR);
SUPPORT(INPUTERROR)
END;
END (*GETPUTRESETREWRITE*);
PROCEDURE CALL←SUPPORT;
BEGIN
IF (LSUPPORT IN [READIRANGE..WRTDSET]) AND ((SY = COMMA) OR (LKEY IN [8,11]))
THEN
BEGIN
IF NOT REG2←SAVED
THEN
BEGIN
REG2←SAVED := TRUE;
REG2←LOCATION := LC;
LC := LC + 1;
IF LC > LCMAX
THEN LCMAX := LC
END;
MACRO4(202B(*MOVEM*),REGC,BASIS,REG2←LOCATION);
SUPPORT(LSUPPORT);
MACRO4(200B(*MOVE*),REGC,BASIS,REG2←LOCATION)
END
ELSE SUPPORT(LSUPPORT)
END;
PROCEDURE READREADLN;
VAR
BOUNDCLASS: CSTCLASS;
LATTR: ATTR;
BASEFORM: STRUCTFORM;
BEGIN
GETFILENAME('INPUT ',[ARROW,RPARENT,COMMA]);
IF (LKEY = 7) OR ((LKEY = 8) AND (SY = IDENT)) OR BUFFER←VARIABLE
THEN
LOOP
IF NOT BUFFER←VARIABLE
THEN
BEGIN
VARIABLE(FSYS + [COMMA]);
LOAD←ADDRESS
END;
LSUPPORT := READINTEGER;
BUFFER←VARIABLE := FALSE;
WITH GATTR DO
IF TYPTR <> NIL
THEN
IF TYPTR↑.FORM IN [SCALAR,SUBRANGE,POWER]
THEN
BEGIN
IF TYPTR = CHARPTR
THEN TYPTR := ASCIIPTR;
BASEFORM := TYPTR↑.FORM;
IF TYPTR↑.FORM = POWER
THEN
BEGIN
TYPTR := TYPTR↑.ELSET;
IF COMPTYPES(TYPTR,ASCIIPTR)
THEN
BEGIN
MACRO3(551B(*HRRZI*),REGC+1,OFFSET);
MACRO3(551B(*HRRZI*),REGC+2,BASEMAX + OFFSET)
END
END;
IF TYPTR <> NIL
THEN
IF TYPTR↑.FORM = SUBRANGE
THEN
BEGIN
IF COMPTYPES(REALPTR,TYPTR↑.RANGETYPE)
THEN BOUNDCLASS := REEL
ELSE BOUNDCLASS := INT;
LATTR.KIND := CST;
LATTR.CVAL := TYPTR↑.VMIN; MACRO2(200B(*MOVE*),REGC+1); DEPOSIT←CONSTANT(BOUNDCLASS,LATTR);
LATTR.CVAL := TYPTR↑.VMAX; MACRO2(200B(*MOVE*),REGC+2); DEPOSIT←CONSTANT(BOUNDCLASS,LATTR);
TYPTR := TYPTR↑.RANGETYPE
END
ELSE
IF TYPTR↑.SCALKIND = DECLARED
THEN
BEGIN
MACRO3(551B(*HRRZI*),REGC+2,TYPTR↑.DIMENSION); MACRO2(400B(*SETZ*),REGC+1)
END;
IF TYPTR <> NIL
THEN
IF TYPTR↑.SCALKIND = DECLARED
THEN
WITH TYPTR↑ DO
BEGIN
REQUEST := TRUE; MACRO3R(551B(*HRRZI*),REGC+3,VECTORCHAIN);
CODE←REFERENCE↑[CIX] := CONSTREF; VECTORCHAIN := IC-1;
LSUPPORT := READ←SUPPORT[DECLAREDFORM,BASEFORM]
END
ELSE
BEGIN
IF TYPTR = INTPTR
THEN LSUPPORT := READ←SUPPORT[INTEGERFORM,BASEFORM]
ELSE
IF COMPTYPES(TYPTR,ASCIIPTR)
THEN LSUPPORT := READ←SUPPORT[CHARFORM,BASEFORM]
ELSE
IF TYPTR = REALPTR
THEN LSUPPORT := READ←SUPPORT[REALFORM,BASEFORM]
ELSE ERROR(458)
END
END
ELSE
IF STRING(TYPTR)
THEN
BEGIN
IF TYPTR↑.ARRAYPF
THEN LSUPPORT := READPACKEDSTRING
ELSE LSUPPORT := READSTRING;
WITH TYPTR↑.INXTYPE↑ DO MACRO3(551B(*HRRZI*),REGC+1,VMAX.IVAL-VMIN.IVAL+1)
END
ELSE ERROR(169);
REGC := REGIN + 1;
CALL←SUPPORT
EXIT IF SY <> COMMA;
INSYMBOL
END;
IF LKEY = 8
THEN SUPPORT(GETLINE)
END (*READREADLN*) ;
PROCEDURE BREAK;
BEGIN
GETFILENAME('TTYOUTPUT ',[RPARENT]);
SUPPORT(PUTBUFFER)
END ;
PROCEDURE WRITEWRITELN;
VAR
LLSP, LSP: STP;
DEFAULT, REALFORMAT, DECLARED←OR←SET: BOOLEAN;
LSIZE, LMIN, LMAX: INTEGER;
BEGIN
IF NOT TTY←MESSAGE
THEN GETFILENAME('OUTPUT ',[RPARENT,COMMA,ARROW,COLON]);
IF (LKEY = 10) OR ((LKEY = 11) AND (SY IN FACBEGSYS + [ADDOP])) OR BUFFER←VARIABLE
THEN
LOOP
IF NOT BUFFER←VARIABLE
THEN EXPRESSION(FSYS + [COMMA,COLON],ONFIXEDREGC);
LSP := GATTR.TYPTR;
LSUPPORT := WRITEINTEGER;
IF LSP <> NIL
THEN
WITH LSP↑ DO
IF FORM <= POWER
THEN
BEGIN
LOAD(GATTR);
DECLARED←OR←SET := (FORM = POWER) OR ((FORM = SCALAR) AND (SCALKIND = DECLARED) AND NOT (LSP = BOOLPTR))
END
ELSE
BEGIN
IF NOT BUFFER←VARIABLE
THEN LOAD←ADDRESS;
DECLARED←OR←SET := FALSE
END;
BUFFER←VARIABLE := FALSE;
IF SY = COLON
THEN
BEGIN
INSYMBOL;
EXPRESSION(FSYS + [COMMA,COLON],ONFIXEDREGC);
IF GATTR.TYPTR <> NIL
THEN
BEGIN
IF GATTR.TYPTR <> INTPTR
THEN ERROR(458);
IF GATTR.KIND <> EXPR
THEN
BEGIN
GENERATE←CODE( 200B (*MOVE*) , REGIN+3 , GATTR ) ;
REGC := GATTR.REG ;
END ;
END ;
DEFAULT := FALSE
END
ELSE
BEGIN
DEFAULT := TRUE;
INCREMENT←REGC (*RESERVE REGISTER FOR DEFAULT VALUE*)
END ;
IF SY = COLON
THEN
BEGIN
INSYMBOL;
IF COMPTYPES(LSP,INTPTR)
THEN
BEGIN
IF (SY = IDENT) AND ((ID='O ') OR (ID='H '))
THEN
IF ID = 'O '
THEN LSUPPORT := WRITEOCTAL
ELSE LSUPPORT := WRITEHEXADECIMAL
ELSE ERROR(262);
INSYMBOL
END
ELSE
BEGIN
EXPRESSION(FSYS + [COMMA],ONFIXEDREGC);
IF GATTR.TYPTR <> NIL
THEN
IF GATTR.TYPTR <> INTPTR
THEN ERROR(458);
IF LSP <> REALPTR
THEN ERROR(258);
LOAD(GATTR);
REALFORMAT := FALSE
END
END
ELSE REALFORMAT := TRUE;
IF LSP <> INTPTR
THEN
BEGIN
IF COMPTYPES(LSP,ASCIIPTR)
THEN LSUPPORT := WRITECHARACTER
ELSE
IF LSP = REALPTR
THEN
IF REALFORMAT
THEN LSUPPORT := WRITEDEF1REAL
ELSE LSUPPORT := WRITEREAL
ELSE
IF LSP = BOOLPTR
THEN LSUPPORT := WRITEBOOLEAN
ELSE
WITH LSP↑ DO
IF STRING(LSP)
THEN
BEGIN
IF INXTYPE <> NIL
THEN
BEGIN
GETBOUNDS(INXTYPE,LMIN,LMAX);
LSIZE := LMAX-LMIN+1
END
ELSE LSIZE := 0;
MACRO3(551B(*HRRZI*),REGIN+4,LSIZE);
IF ARRAYPF
THEN LSUPPORT := WRITEPACKEDSTRING
ELSE LSUPPORT := WRITESTRING
END
ELSE
IF (LSP <> NIL) AND DECLARED←OR←SET
THEN
BEGIN
IF FORM = POWER
THEN
BEGIN
IF ELSET <> NIL
THEN
IF ELSET↑.FORM = SUBRANGE
THEN LLSP := ELSET↑.RANGETYPE
ELSE LLSP := ELSET
END
ELSE LLSP := LSP;
IF LLSP <> NIL
THEN
IF LLSP↑.SCALKIND = DECLARED
THEN
WITH LLSP↑ DO
BEGIN
IF DEFAULT
THEN MACRO3(515B(*HRLZI*),REGC,DIMENSION)
ELSE MACRO3(505B(*HRLI*),REGC,DIMENSION);
MACRO3R(551B(*HRRZI*),REGC+1,VECTORCHAIN);
VECTORCHAIN := IC-1; REQUEST := TRUE;
CODE←REFERENCE↑[CIX] := CONSTREF; LSUPPORT := WRITE←SUPPORT[DECLAREDFORM,LSP↑.FORM]
END
ELSE
BEGIN
IF DEFAULT
THEN MACRO2(400B(*SETZ*),REGC);
IF LLSP = INTPTR
THEN LSUPPORT := WRITE←SUPPORT[INTEGERFORM,FORM]
ELSE
IF COMPTYPES(LLSP,ASCIIPTR)
THEN LSUPPORT := WRITE←SUPPORT[CHARFORM,FORM]
ELSE ERROR(458)
END
END
ELSE ERROR(458)
END;
IF DEFAULT AND NOT DECLARED←OR←SET
THEN LSUPPORT := SUCC( LSUPPORT );
REGC :=REGIN + 1;
CALL←SUPPORT
EXIT IF SY <> COMMA;
INSYMBOL
END (* LOOP *);
IF LKEY = 11
THEN SUPPORT(PUTLINE)
END (*WRITE*) ;
PROCEDURE MESSAGE;
(* MESSAGE(<ARGUMENT LIST>)
IS EQUIVALENT TO
WRITELN(TTY);
WRITELN(TTY,<ARGUMENT LIST>);
BREAK(TTY); *)
BEGIN
INCREMENT←REGC;
MACRO3R(551B(*HRRZI*),REGC,STDFILEPTR[4]↑.VADDR);
IF EXTERNAL
THEN STDFILEPTR[4]↑.VADDR := IC - 1;
SUPPORT(PUTLINE);
LKEY := 10; TTY←MESSAGE := TRUE;
WRITEWRITELN;
TTY←MESSAGE := FALSE;
SUPPORT(PUTLINE); SUPPORT(PUTBUFFER)
END;
PROCEDURE PACKUNPACK;
(******************************************************************************
*
* PACK(A,I,Z<,J<,L>>) EXECUTES: FOR K := 0 TO L1-1 DO Z[J1+K] := A[I+K]
*
* UNPACK(Z,A,I<,J<,L>>) EXECUTES: FOR K := 0 TO L1-1 DO A[I+K] := Z[J1+K]
*
* A IS AN ARRAY OF A SCALAR-TYPE,
* Z IS A PACKED ARRAY OF THIS TYPE (SO THE BITSIZE MUST BE <= 18),
* I IS THE ABSOLUTE START-INDEX IN A,
* J IS THE ABSOLUTE START-INDEX IN Z,
* L IS THE NUMBER OF ELEMENTS TO BE PACKED/UNPACKED,
* J1 IS J (DEFAULT: LOWERBOUND(Z)),
* L1 IS L (DEFAULT: MIN(UPPERBOUND(Z)-J1,UPPERBOUND(A)-I)+1),
* K IS NOT DENOTED ELSEWHERE IN THE PROGRAM.
*
******************************************************************************)
VAR
A,I,Z,J,L: ATTR; LREGC: ACRANGE;
LENGTH, ASTART, ZSTART, AMAX, AMIN, ZMAX, ZMIN, PACKFACTOR: INTEGER;
DEFAULT←LENGTH: BOOLEAN;
PROCEDURE ADJUST( VAR FATTR: ATTR; FBOUND: INTEGER);
BEGIN
LOAD(FATTR);
IF FBOUND < 0
THEN MACRO3(271B(*ADDI*),FATTR.REG,-FBOUND)
ELSE
IF FBOUND > 0
THEN MACRO3(275B(*SUBI*),FATTR.REG,FBOUND);
IF RUNTIME←CHECK
THEN
BEGIN
MACRO2(305B(*CAIGE*),FATTR.REG);
SUPPORT(INDEXERROR)
END
END;
PROCEDURE GETOFFSET( VAR FATTR: ATTR; FSYS: SETOFSYS; COMPTYPTR: STP);
BEGIN
EXPRESSION(FSYS,ONREGC); FATTR := GATTR;
IF NOT ERROR←FLAG
THEN
WITH FATTR DO
IF TYPTR <> NIL
THEN
IF NOT COMPTYPES(TYPTR,COMPTYPTR)
THEN ERROR(458);
IF (SY=COMMA) AND (COMMA IN FSYS)
THEN INSYMBOL
ELSE
IF (SY <> RPARENT) OR NOT (RPARENT IN FSYS)
THEN ERROR(458)
END;
PROCEDURE GETVAR( VAR FATTR: ATTR; FSYS: SETOFSYS; COMPTYPTR: STP);
BEGIN
VARIABLE(FSYS); LOAD←ADDRESS; FATTR := GATTR;
IF NOT ERROR←FLAG
THEN
WITH FATTR DO
IF TYPTR <> NIL
THEN
WITH TYPTR↑ DO
IF FORM = ARRAYS
THEN
BEGIN
IF COMPTYPTR = NIL
THEN
IF LKEY = 12
THEN
BEGIN
IF ARRAYPF
THEN ERROR(458)
END
ELSE
BEGIN
IF NOT ARRAYPF
THEN ERROR(458)
END
ELSE
IF NOT ((ARRAYPF <> COMPTYPTR↑.ARRAYPF) AND
COMPTYPES(AELTYPE,COMPTYPTR↑.AELTYPE) AND
COMPTYPES(INXTYPE,COMPTYPTR↑.INXTYPE))
THEN ERROR(458);
KIND := EXPR;
IF ARRAYPF
THEN
BEGIN
REG := REG1; REGC := REGC-1;
CODE←ARRAY↑.INSTRUCTION[CIX].AC := REG1
END
ELSE REG := INDEXR
END
ELSE ERROR(458);
IF (SY = COMMA) AND (COMMA IN FSYS)
THEN INSYMBOL
ELSE
IF (SY <> RPARENT) OR NOT (RPARENT IN FSYS)
THEN ERROR(458)
END;
BEGIN (* PACKUNPACK *)
LREGC := REGC; DEFAULT←LENGTH := TRUE;
IF LKEY = 12
THEN
BEGIN
GETVAR(A,[COMMA],NIL);
IF A.TYPTR <> NIL
THEN GETOFFSET(I,[COMMA],A.TYPTR↑.INXTYPE)
ELSE GETOFFSET(I,[COMMA],NIL);
GETVAR(Z,[COMMA,RPARENT],A.TYPTR)
END
ELSE
BEGIN
GETVAR(Z,[COMMA],NIL);
GETVAR(A,[COMMA],Z.TYPTR);
IF A.TYPTR <> NIL
THEN GETOFFSET(I,[COMMA,RPARENT],A.TYPTR↑.INXTYPE)
ELSE GETOFFSET(I,[COMMA,RPARENT],NIL)
END;
IF NOT ERROR←FLAG
THEN
BEGIN
GETBOUNDS(A.TYPTR↑.INXTYPE,AMIN,AMAX); AMAX := AMAX-AMIN;
GETBOUNDS(Z.TYPTR↑.INXTYPE,ZMIN,ZMAX); ZMAX := ZMAX-ZMIN;
END;
WITH J DO
BEGIN
KIND := CST; CVAL.IVAL := ZMIN
END;
WITH L DO
BEGIN
KIND := CST; CVAL.IVAL := 0
END;
IF SY <> RPARENT
THEN
BEGIN
IF Z.TYPTR <> NIL
THEN GETOFFSET(J,[COMMA,RPARENT],Z.TYPTR↑.INXTYPE)
ELSE GETOFFSET(J,[COMMA,RPARENT],NIL);
IF SY <> RPARENT
THEN
BEGIN
DEFAULT←LENGTH := FALSE;
GETOFFSET(L,[RPARENT],INTPTR)
END
END;
IF NOT ERROR←FLAG
THEN
BEGIN
ASTART := 0; PACKFACTOR := BITMAX DIV Z.TYPTR↑.AELTYPE↑.BITSIZE;
IF (I.KIND = CST) AND (J.KIND = CST) AND (L.KIND = CST)
THEN
BEGIN
ASTART := I.CVAL.IVAL - AMIN;
ZSTART := J.CVAL.IVAL - ZMIN;
IF (ASTART >= 0) AND (ZSTART >= 0)
THEN
BEGIN
LENGTH := MIN(ZMAX-ZSTART, AMAX-ASTART) + 1;
IF LENGTH >= 0
THEN
BEGIN
IF NOT DEFAULT←LENGTH
THEN
IF (L.CVAL.IVAL >= 0) AND (L.CVAL.IVAL <= LENGTH)
THEN LENGTH := L.CVAL.IVAL
ELSE ERROR(263);
MACRO3(505B(*HRLI*),A.REG,-LENGTH);
IF (ZSTART DIV PACKFACTOR) <> 0
THEN
MACRO3(271B(*ADDI*),Z.REG,ZSTART DIV PACKFACTOR);
MACRO3R(200B(*MOVE*),REGC+1,Z.TYPTR↑.ARRAYBPADDR+(ZSTART MOD PACKFACTOR))
END
ELSE ERROR(263)
END
ELSE ERROR(263)
END
ELSE (* KIND <> CST *)
BEGIN
ADJUST(I,AMIN);
MACRO3(270B(*ADD*),A.REG,I.REG);
ADJUST(J,ZMIN);
IF RUNTIME←CHECK OR DEFAULT←LENGTH
THEN
BEGIN
MACRO3(275B(*SUBI*),I.REG,AMAX);
MACRO3(200B(*MOVE*),REGC+1,J.REG);
MACRO3(275B(*SUBI*),REGC+1,ZMAX);
MACRO3(315B(*CAMGE*),I.REG,REGC+1);
MACRO3(200B(*MOVE*),I.REG,REGC+1);
IF RUNTIME←CHECK
THEN
BEGIN
MACRO2(303B(*CAILE*),I.REG);
SUPPORT(INDEXERROR)
END;
IF DEFAULT←LENGTH
THEN MACRO4(505B(*HRLI*),A.REG,I.REG,-1)
END;
IF NOT DEFAULT←LENGTH
THEN
IF RUNTIME←CHECK OR (L.KIND <> CST)
THEN
BEGIN
GENERATE←CODE(210B(*MOVN*),REGC+1,L);
IF RUNTIME←CHECK
THEN
BEGIN
MACRO2(307B(*CAIG*),L.REG);
MACRO3(315B(*CAMGE*),L.REG,I.REG);
SUPPORT(INDEXERROR)
END;
MACRO3(504B(*HRL*),A.REG,L.REG)
END
ELSE MACRO3(505B(*HRLI*),A.REG,-L.CVAL.IVAL);
MACRO3(231B(*IDIVI*),J.REG,PACKFACTOR);
MACRO3(270B(*ADD*),Z.REG,J.REG);
MACRO4R(200B(*MOVE*),REGC+1,J.REG+1,Z.TYPTR↑.ARRAYBPADDR)
END;
IF LKEY = 12
THEN
BEGIN
MACRO4(200B(*MOVE*),REG0,A.REG,ASTART);
MACRO3(136B(*IDPB*),REG0,REGC+1)
END
ELSE
BEGIN
MACRO3(134B(*ILDB*),REG0,REGC+1);
MACRO4(202B(*MOVEM*),REG0,A.REG,ASTART)
END;
MACRO3R(253B(*AOBJN*),A.REG,IC-2)
END (* IF NOT ERROR←FLAG *)
END (* PACKUNPACK *);
PROCEDURE NEWDISPOSE;
(* "NEW" ALLOCATES STORAGE FOR A DYNAMIC VARIABLE
(F.E. A RECORD VARIANT) IN THE HEAP.
"DISPOSE" DE-ALLOCATES THE STORAGE OCCUPIED BY
SUCH A VARIABLE AND IN THIS IMPLEMENTATION IT
DE-ALLOCATES THE STORAGE OF ALL VARIABLES ALLOCATED
LATER THAN THE SPECIFIED ONE TOO.
THIS IS DUE TO THE STACK-LIKE HEAP MANAGEMENT
WITH ONLY "NEWREG" POINTING TO THE LAST ALLOCATED
WORD OF CORE*)
LABEL
777;
VAR
LSP,LSP1: STP; VARTS,LMIN,LMAX: INTEGER;
LNLK : NLK;
LENGTHREG: ACRANGE;
LSIZE,LSZ: ADDRRANGE; LVAL: VALU;
LATTRC, LATTR: ATTR; I,TAGFC: INTEGER;
TAGFSAV: ARRAY[0..TAGFMAX] OF RECORD
TAGFVAL: INTEGER;
TAGTYPE: TAGFWITHID..TAGFWITHOUTID;
CASE TPACKKIND: PACKKIND OF
NOTPACK,
HWORDL,
HWORDR: (TAGFADDR: ADDRRANGE);
PACKK: (TAGFBYTE: BPOINTER)
END;
BEGIN
INCREMENT←REGC; VARIABLE(FSYS + [COMMA,COLON]);
IF LKEY = 24 (*DISPOSE*)
THEN
BEGIN
GENERATE←CODE(200B(*MOVE*),REG0,GATTR);
LENGTHREG := REG1
END
ELSE LENGTHREG := REGIN + 1;
LSP := NIL; VARTS := 0; LSIZE := 0; TAGFC := -1;
LATTR := GATTR;
IF GATTR.TYPTR <> NIL
THEN WITH GATTR.TYPTR↑ DO
IF FORM = POINTER
THEN
BEGIN
IF ELTYPE <> NIL
THEN
BEGIN
LSIZE := ELTYPE↑.SIZE;
IF ELTYPE↑.FORM = RECORDS
THEN LSP := ELTYPE↑.RECVAR
ELSE
IF ELTYPE↑.FORM = ARRAYS
THEN LSP := ELTYPE
END
END
ELSE ERROR(458);
WHILE SY = COMMA DO
BEGIN
INSYMBOL; CONSTANT(FSYS + [COMMA,COLON],LSP1,LVAL);
VARTS := VARTS + 1;
IF LSP <> NIL
THEN
IF NOT (STRING(LSP) OR (LSP1 = REALPTR))
THEN
BEGIN
TAGFC := TAGFC + 1;
IF TAGFC <= TAGFMAX
THEN
IF LSP↑.FORM = TAGFWITHID
THEN
BEGIN
IF LSP↑.TAGFIELDP <> NIL
THEN
IF COMPTYPES(LSP↑.TAGFIELDP↑.IDTYPE,LSP1)
THEN
WITH TAGFSAV[TAGFC], LSP↑.TAGFIELDP↑ DO
BEGIN
TAGFVAL := LVAL.IVAL;
TAGTYPE := TAGFWITHID; TPACKKIND := PACKF;
IF TPACKKIND = PACKK
THEN TAGFBYTE := FLDBYTE
ELSE TAGFADDR := FLDADDR
END
ELSE ERROR(458)
END
ELSE
IF LSP↑.FORM = TAGFWITHOUTID
THEN
IF COMPTYPES(LSP↑.TAGFIELDTYPE,LSP1)
THEN TAGFSAV[TAGFC].TAGTYPE := TAGFWITHOUTID
ELSE ERROR(458)
ELSE ERROR(358)
ELSE
BEGIN
ERROR(409); TAGFC := TAGFMAX
END;
LSP1 := LSP↑.FSTVAR;
WHILE LSP1 <> NIL DO
WITH LSP1↑ DO
IF VARVAL.IVAL = LVAL.IVAL
THEN
BEGIN
LSIZE := SIZE; LSP := SUBVAR; GOTO 777
END
ELSE LSP1 := NXTVAR;
LSIZE := LSP↑.SIZE; LSP := NIL;
777:
END
ELSE ERROR(460)
ELSE ERROR(408)
END (*WHILE*) ;
IF SY = COLON
THEN
BEGIN
INSYMBOL;
EXPRESSION(FSYS,ONREGC);
IF LSP = NIL
THEN ERROR(408)
ELSE
IF LSP↑.FORM <> ARRAYS
THEN ERROR(259)
ELSE
BEGIN
IF NOT COMPTYPES(GATTR.TYPTR,LSP↑.INXTYPE)
THEN ERROR(458);
LSZ := 1; LMIN := 1;
IF LSP↑.INXTYPE <> NIL
THEN GETBOUNDS(LSP↑.INXTYPE,LMIN,LMAX);
IF LSP↑.AELTYPE <> NIL
THEN LSZ := LSP↑.AELTYPE↑.SIZE;
LOAD(GATTR);
IF LSZ <> 1
THEN MACRO3(221B(*IMULI*),REGC,LSZ);
IF LSP↑.ARRAYPF
THEN
BEGIN
MACRO3(271B(*ADDI*),REGC,LSP↑.AELTYPE↑.BITSIZE-1);
INCREMENT←REGC; REGC := REGC - 1;
(*FOR TESTING BECAUSE IDIV WORKS ON AC+1 TOO*)
MACRO3(231B(*IDIVI*),REGC,BITMAX DIV LSP↑.AELTYPE↑.BITSIZE);
LSZ := LSIZE - LSP↑.SIZE + 1
END
ELSE LSZ := LSIZE - LSP↑.SIZE - LSZ*(LMIN - 1);
MACRO4(551B(*HRRZI*),LENGTHREG,REGC,LSZ)
END
END
ELSE MACRO3(551B(*HRRZI*),LENGTHREG,LSIZE);
IF LKEY = 14
THEN
BEGIN
IF DEBUG←SWITCH
THEN
BEGIN
MACRO3(540B(* HRR *),REG0,NEWREG);
IF LATTR.TYPTR <> NIL
THEN
IF LATTR.TYPTR↑.ELTYPE <> NIL
THEN
BEGIN
MACRO3R(505B(* HRLI *), REG0,0);
CODE←REFERENCE↑[CIX] := DEBUGREF;
NEW(LNLK);
WITH LNLK↑ DO
BEGIN
REFADR := IC - 1;
REFTYPE := LATTR.TYPTR↑.ELTYPE;
NEXT := GLOBNEWLINK;
GLOBNEWLINK := LNLK;
END;
END
END;
SUPPORT(ALLOCATE);
IF DEBUG←SWITCH
THEN
BEGIN
MACRO3(360B(*SOJ*),NEWREG,0);
MACRO4(202B(*MOVEM*),REG0,NEWREG,0)
END;
REGC := REGIN+1;
FOR I := 0 TO TAGFC DO
WITH TAGFSAV[I] DO
BEGIN
IF TAGTYPE = TAGFWITHID
THEN
BEGIN
MACRO3(551B(*HRRZI*),REG0,TAGFVAL);
CASE TPACKKIND OF
NOTPACK:
MACRO4(202B(*MOVEM*),REG0,REGC,TAGFADDR);
HWORDR:
MACRO4(542B(*HRRM*),REG0,REGC,TAGFADDR);
HWORDL:
MACRO4(506B(*HRLM*),REG0,REGC,TAGFADDR);
PACKK :
BEGIN
WITH LATTRC, CVAL, BYTE DO
BEGIN
KIND := CST;
CVAL.BYTE := TAGFBYTE;
IREG := REGC
END;
MACRO2(137B(*DPB*),REG0); DEPOSIT←CONSTANT(BPTR,LATTRC)
END
END(*CASE*)
END
END;
STORE(REGC,LATTR)
END
ELSE SUPPORT(FREE)
END (*NEWDISPOSE*) ;
PROCEDURE FIRSTLAST;
(* RETURN LOWER- OR UPPERBOUND OF "STANDARD SCALARS",
"DECLARED SCALARS" AND THEIR "SUBRANGES"*)
VAR
LMIN, LMAX: INTEGER;
BEGIN
VARIABLE(FSYS + [RPARENT]);
IF GATTR.TYPTR <> NIL
THEN
WITH GATTR DO
IF NOT COMPTYPES(REALPTR,TYPTR)
THEN
BEGIN
GETBOUNDS(TYPTR,LMIN,LMAX);
KIND := CST;
IF LKEY = 21
THEN CVAL.IVAL := LMIN
ELSE CVAL.IVAL := LMAX;
IF TYPTR↑.FORM = SUBRANGE
THEN TYPTR := TYPTR↑.RANGETYPE
END
ELSE ERROR(459)
END;
PROCEDURE LOWERUPPERBOUND;
(* RETURN LOWER- OR UPPERBOUND OF
ARRAY INDEX TYPE*)
VAR
LMIN, LMAX: INTEGER;
BEGIN
VARIABLE(FSYS + [RPARENT]);
IF GATTR.TYPTR <> NIL
THEN
WITH GATTR DO
IF (TYPTR↑.FORM = ARRAYS) AND (TYPTR↑.INXTYPE <> NIL)
THEN
BEGIN
GETBOUNDS(TYPTR↑.INXTYPE,LMIN,LMAX);
KIND := CST;
IF LKEY = 15
THEN CVAL.IVAL := LMIN
ELSE CVAL.IVAL := LMAX;
IF TYPTR↑.INXTYPE↑.FORM = SUBRANGE
THEN TYPTR := TYPTR↑.INXTYPE↑.RANGETYPE
ELSE TYPTR := TYPTR↑.INXTYPE
END
ELSE ERROR(459)
END;
PROCEDURE MINMAX;
(* THIS PROCEDURE GENERATES CODE FOR THE MIN/MAX FUNCTION.
THE MAXIMUM NUMBER OF SCALAR-TYPE EXPRESSIONS -EXCEPT REAL-
IS 72 *)
CONST
TOPP←OFFSET = 2;
MAX←EXPR = 72;
VAR
I, J: INTEGER;
LREGC: ACRANGE;
INSERT←SIZE: CODERANGE;
LINSTR: INSTRANGE;
FIRST←EXPRESSION, CONVERSION: BOOLEAN;
SELECTOR: SCALARFORM;
ARGUMENT: PACKED ARRAY[1..MAX←EXPR] OF SCALARFORM;
BEGIN
FIRST←EXPRESSION := TRUE;
CONVERSION := FALSE;
I := 1;
LREGC := REGC;
MACRO4(307B(*CAIG*),NEWREG,TOPP,0); INSERT←SIZE := CIX;
SUPPORT(STACKOVERFLOW);
LOOP
EXPRESSION(FSYS + [COMMA,RPARENT], ONFIXEDREGC);
IF GATTR.TYPTR <> NIL
THEN
IF GATTR.TYPTR↑.FORM <> SCALAR
THEN ERROR(458)
ELSE
WITH GATTR DO
BEGIN
LOAD(GATTR);
IF TYPTR = INTPTR
THEN ARGUMENT[I] := INTEGERFORM
ELSE
IF TYPTR = REALPTR
THEN ARGUMENT[I] := REALFORM
ELSE
IF COMPTYPES(TYPTR,ASCIIPTR)
THEN ARGUMENT[I] := CHARFORM
ELSE
IF (TYPTR↑.SCALKIND = DECLARED) AND (TYPTR <> BOOLPTR)
THEN ARGUMENT[I] := DECLAREDFORM
ELSE ERROR(458);
MACRO4(202B(*MOVEM*),REG,TOPP,TOPP←OFFSET + I);
IF FIRST←EXPRESSION
THEN
BEGIN
FIRST←EXPRESSION := FALSE; SELECTOR := ARGUMENT[I]
END
ELSE
IF SELECTOR <> ARGUMENT[I]
THEN
IF [SELECTOR,ARGUMENT[I]] <= [INTEGERFORM,REALFORM]
THEN
BEGIN
CONVERSION := TRUE; SELECTOR := REALFORM
END
ELSE ERROR(458)
END
EXIT IF SY <> COMMA;
I := I + 1;
IF I > MAX←EXPR
THEN
BEGIN
ERROR(458); I := 1
END;
INSYMBOL;
REGC := LREGC
END;
IF (I > 1) AND NOT ERROR←FLAG
THEN
BEGIN
INSERT←ADDRESS(NO, INSERT←SIZE, TOPP←OFFSET + I);
IF CONVERSION
THEN
FOR J := 1 TO I DO
IF ARGUMENT[J] = INTEGERFORM
THEN
BEGIN
MACRO4(551B(*HRRZI*),REG1,TOPP,TOPP←OFFSET + J);
SUPPORT(CONVERTINTEGERTOREAL)
END;
INCREMENT←REGC;
MACRO4(541B(*HRRI*),REGC,TOPP,TOPP←OFFSET + 2);
MACRO3(505B(*HRLI*),REGC,-(I - 1));
MACRO4(200B(*MOVE*),GATTR.REG,TOPP,TOPP←OFFSET + 1);
IF LKEY = 20
THEN LINSTR := 315B(*CAMGE*)
ELSE LINSTR := 313B(*CAMLE*);
MACRO4(LINSTR,GATTR.REG,REGC,0);
MACRO4(200B(*MOVE*),GATTR.REG,REGC,0);
MACRO3(253B(*AOBJN*),REGC,IC - 2);
IF CONVERSION
THEN GATTR.TYPTR := REALPTR
END
END;
PROCEDURE GETLINENR;
BEGIN
GETFILENAME('INPUT ',[COMMA]);
LOAD(GATTR);
VARIABLE(FSYS);
IF COMPTYPES(GATTR.TYPTR,PACKC5PTR)
THEN STORE(REGC,GATTR)
ELSE ERROR(458)
END;
PROCEDURE PAGE;
BEGIN
GETFILENAME('OUTPUT ',[RPARENT]);
SUPPORT(PUTPAGE)
END;
PROCEDURE DATE; (* ASSIGN DATE IN STANDARD DD-MMM-YY FORMAT TO ALFA PARAMETER *)
BEGIN
VARIABLE(FSYS);
IF COMPTYPES(ALFAPTR,GATTR.TYPTR)
THEN LOAD←ADDRESS
ELSE ERROR(458);
SUPPORT(ASCIIDATE)
END;
PROCEDURE TIME; (* ASSIGN TIME IN STANDARD HH:MM:SS FORMAT TO ALFA PARAMETER *)
BEGIN
VARIABLE(FSYS);
IF COMPTYPES(ALFAPTR,GATTR.TYPTR)
THEN LOAD←ADDRESS
ELSE ERROR(458);
SUPPORT(ASCIITIME)
END;
PROCEDURE CLOCK; (* RETURN THE ELAPSED CPU-TIME IN MILLISECONDS *)
BEGIN
WITH GATTR DO
BEGIN
INCREMENT←REGC; TYPTR := INTPTR; REG := REGC; KIND := EXPR;
MACRO3(047B,REGC,30B(*PJOB-UUO*));
MACRO3(047B,REGC,27B(*RUNTIM-UUO*))
END
END;
PROCEDURE CARD; (* RETURN THE CARDINAL NUMBER OF A SET *)
VAR
LOOP←AROUND: ADDRRANGE;
BEGIN
WITH GATTR DO
BEGIN
IF TYPTR <> NIL
THEN
IF TYPTR↑.FORM <> POWER
THEN ERROR(459)
ELSE
BEGIN
INCREMENT←REGC; INCREMENT←REGC;
MACRO3(551B(*HRRZI*),REGC,72);
MACRO2(400B(*SETZ*),REGC-1);
LOOP←AROUND := IC;
MACRO2(305B(*CAIGE*),GATTR.REG - 1);
MACRO2(340B(*AOJ*),REGC-1);
MACRO3(246B(*LSHC*),GATTR.REG - 1,1);
MACRO3R(367B(*SOJG*),REGC,LOOP←AROUND);
REGC := REGC - 1;
KIND := EXPR; REG := REGC; TYPTR := INTPTR
END
END
END;
PROCEDURE ABS;
BEGIN
WITH GATTR DO
IF (TYPTR = INTPTR) OR (TYPTR = REALPTR)
THEN
IF KIND=EXPR
THEN MACRO3(214B(*MOVM*),REG,REG)
ELSE
BEGIN
INCREMENT←REGC;
GENERATE←CODE(214B(*MOVM*),REGC,GATTR)
END
ELSE
BEGIN
ERROR(459); TYPTR:= INTPTR
END
END (*ABS*) ;
PROCEDURE REALTIME;
(* RETURN THE DAY-TIME
IN MILLISECONDS *)
BEGIN
WITH GATTR DO
BEGIN
INCREMENT←REGC; TYPTR := INTPTR; REG := REGC; KIND := EXPR;
MACRO3(047B,REGC,23B(*MSTIME-UUO*))
END
END;
PROCEDURE SQR;
BEGIN
WITH GATTR DO
IF TYPTR = INTPTR
THEN MACRO3(220B(*IMUL*),REG,REG)
ELSE
IF TYPTR = REALPTR
THEN MACRO3(164B(*FMPR*),REG,REG)
ELSE
BEGIN
ERROR(459); TYPTR := INTPTR
END
END (*SQR*) ;
PROCEDURE ODD;
BEGIN
WITH GATTR DO
BEGIN
IF TYPTR <> INTPTR
THEN ERROR(459);
MACRO3(405B(*ANDI*),REG,1);
TYPTR := BOOLPTR
END
END (*ODD*) ;
PROCEDURE ORD;
BEGIN
IF GATTR.TYPTR <> NIL
THEN
IF GATTR.TYPTR↑.FORM >= POWER
THEN ERROR(459);
GATTR.TYPTR := INTPTR
END (*ORD*) ;
PROCEDURE CHR;
BEGIN
IF GATTR.TYPTR <> INTPTR
THEN ERROR(459);
GATTR.TYPTR := CHARPTR
END (*CHR*) ;
PROCEDURE PREDSUCC;
VAR
LSP:STP;
PMIN,PMAX: INTEGER;
BEGIN
IF GATTR.TYPTR <> NIL
THEN
IF (GATTR.TYPTR↑.FORM>SUBRANGE) OR (GATTR.TYPTR=REALPTR)
THEN ERROR(459)
ELSE
BEGIN
LSP := GATTR.TYPTR;
IF (LSP↑.FORM = SUBRANGE)
THEN LSP := LSP↑.RANGETYPE;
IF RUNTIME←CHECK AND (LSP <> INTPTR)
THEN
BEGIN
IF LKEY=8
THEN MACRO3R(365B(*SOJGE*),REGC,IC+2)
ELSE
BEGIN
MACRO2(340B(*AOJ*),REGC);
GETBOUNDS(LSP,PMIN,PMAX);
MACRO3(303B(*CAILE*),REGC,PMAX)
END;
SUPPORT(ERRORINASSIGNMENT)
END (* RUNTIME←CHECK *)
ELSE
IF LKEY = 8
THEN MACRO2(360B(*SOJ*),REGC)
ELSE MACRO2(340B(*AOJ*),REGC)
END
END (*PREDSUCC*) ;
PROCEDURE EOFEOLN;
BEGIN
GETFILENAME('INPUT ',[RPARENT]);
WITH GATTR DO
BEGIN
IF LKEY=10
THEN
BEGIN
INCREMENT←REGC; GENERATE←CODE(332B(*SKIPE*),REGC,GATTR);
MACRO3(551B(*HRRZI*),REGC,1)
END;
TYPTR := BOOLPTR
END
END (*EOFEOLN*) ;
PROCEDURE PROTECTION;
(* THIS PROCEDURE IS USED BY "PASDDT" TO TEST
IF A PROGRAM'S HIGH-SEGMENT IS SHARED
(WRITE-PROTECTED). PROGRAMS WHICH ARE
TO BE "DEBUGGED" MUST NOT BE SHARABLE.
FOR DETAILS SEE DECSYSTEM-10 "MONITOR-CALLS"
MANUAL, 3.2.4 *)
BEGIN
EXPRESSION(FSYS, ONREGC);
IF GATTR.TYPTR = BOOLPTR
THEN
BEGIN
LOAD(GATTR);
MACRO3(047B,GATTR.REG,36B(*SETUWP-UUO*));
MACRO3(254B(*HALT*),4,0)
END
ELSE ERROR(458)
END;
PROCEDURE CALL;
(* THE STANDARD PROCEDURE
CALL(<FILENAME>[,<DEVICE>[,<PROJECT-PROGRAMMER>[,<CORE-ASSIGNMENT]]])
ALLOWS TO EXIT FROM ONE PROGRAM AND EXECUTE ANOTHER *)
VAR
I:INTEGER;
DEFAULT:ARRAY[2..4] OF BOOLEAN;
PROCEDURE GETSTRINGADDRESS(FLENGTH: INTEGER);
BEGIN
EXPRESSION(FSYS + [COMMA],ONFIXEDREGC);
WITH GATTR DO
IF STRING(TYPTR)
THEN
WITH TYPTR↑ DO
IF ARRAYPF AND (SIZE = 2) AND ((INXTYPE↑.VMAX.IVAL-INXTYPE↑.VMIN.IVAL+1) = FLENGTH)
THEN LOAD←ADDRESS
ELSE ERROR(458)
ELSE ERROR(458)
END;
BEGIN (* CALL *)
IF NOT EXTERNAL
THEN
BEGIN
CLOSE←FILES;
GETSTRINGADDRESS(9);
FOR I := 2 TO 4 DO DEFAULT[I] := TRUE;
IF SY = COMMA
THEN
BEGIN
INSYMBOL; GETSTRINGADDRESS(6); DEFAULT[2] := FALSE;
IF SY = COMMA
THEN
BEGIN
INSYMBOL; EXPRESSION(FSYS + [COMMA],ONFIXEDREGC);
IF GATTR.TYPTR = INTPTR
THEN
BEGIN
DEFAULT[3] := FALSE; LOAD(GATTR)
END
ELSE ERROR(458);
IF SY = COMMA
THEN
BEGIN
INSYMBOL; EXPRESSION(FSYS,ONFIXEDREGC);
IF GATTR.TYPTR = INTPTR
THEN
BEGIN
DEFAULT[4] := FALSE; LOAD(GATTR)
END
ELSE ERROR(458)
END
END
END;
FOR I := 2 TO 4 DO
IF DEFAULT[I]
THEN
BEGIN
INCREMENT←REGC; MACRO2(400B(*SETZ*),REGC)
END;
SUPPORT(RUNPROGRAM)
END
ELSE ERROR(353)
END (* CALL *);
PROCEDURE HALT;
(* THIS PROCEDURE CALLS "PASDDT"
IF IT IS LOADED, OTHERWISE IT
EXECUTES A "HALT" INSTRUCTION *)
BEGIN
MACRO3(332B(*SKIPE*),REG1,JBDDT);
MACRO4(265B(*JSP*),REG0,REG1,-2);
MACRO2(254B(*HALT*),4)
END;
PROCEDURE CALL←NON←STANDARD;
VAR
NXT,LNXT,LCP,LCP1: CTP;
LSP: STP;
LKIND: IDKIND; PASCALCALL:BOOLEAN;
SAVE←COUNT,P,I,NUMBER←OF←PARAMETERS: INTEGER;
TOPP←OFFSET,OFFSET,START←OF←PARAMETERLIST,ACTUAL←PARAMETER,FIRST←PARAMETER,LLC: ADDRRANGE;
LREGC: ACRANGE;
FUNCTION COMPPARAM(FCP1,FCP2 : CTP):BOOLEAN;
VAR
OK:BOOLEAN;
BEGIN (*COMPPARAM*)
OK:=TRUE;
WHILE OK AND (FCP1<>NIL) AND (FCP2<>NIL) DO WITH FCP1↑ DO
BEGIN
IF COMPTYPES(IDTYPE,FCP2↑.IDTYPE)
THEN
IF KLASS=FCP2↑.KLASS
THEN
IF KLASS=VARS
THEN
BEGIN
IF VKIND<>FCP2↑.VKIND
THEN
BEGIN
ERROR(370); OK:=FALSE
END
END
ELSE OK:=COMPPARAM(FPARAM,FCP2↑.FPARAM)
ELSE
BEGIN
ERROR(370); OK:=FALSE
END
ELSE
BEGIN
ERROR(370); OK:=FALSE
END;
FCP1:=NEXT; FCP2:=FCP2↑.NEXT
END;
IF FCP1<>FCP2
THEN
BEGIN
ERROR(554); COMPPARAM:=FALSE
END
ELSE COMPPARAM:=OK
END(*COMPPARAM*);
BEGIN
NUMBER←OF←PARAMETERS:= 0; TOPP←OFFSET := 0; START←OF←PARAMETERLIST := 0; ACTUAL←PARAMETER := 0;
WITH FCP↑ DO
BEGIN
LKIND := PFKIND;
IF LKIND=ACTUAL
THEN
BEGIN
NXT:=NEXT;
IF EXTERNDECL
THEN LIBRARY[LANGUAGE].CALLED:=TRUE;
PASCALCALL:=LANGUAGE=PASCALSY
END
ELSE
BEGIN
NXT:=FPARAM;
PASCALCALL:=TRUE
END;
LNXT:=NXT;
IF KLASS = FUNC
THEN FIRST←PARAMETER := 2
ELSE FIRST←PARAMETER := 1;
SAVE←COUNT := REGC - REGIN;
IF SAVE←COUNT > 0
THEN
BEGIN
LLC := LC ;
LC := LC + SAVE←COUNT ;
IF LC > LCMAX
THEN LCMAX := LC ;
IF SAVE←COUNT > 3
THEN
BEGIN
MACRO3(515B(*HRLZI*),REG1,2);
MACRO4(541B(*HRRI*),REG1,BASIS,LLC);
MACRO4(251B(*BLT*),REG1,BASIS,LLC+SAVE←COUNT-1)
END
ELSE FOR I := 1 TO SAVE←COUNT DO MACRO4(202B(*MOVEM*),REGIN+I,BASIS,LLC+I-1)
END;
LREGC:= REGC;
IF LKIND=ACTUAL
THEN
IF LANGUAGE <> PASCALSY
THEN REGC:= HIGHEST←REGISTER
ELSE REGC:= REGIN
ELSE REGC:=REGIN
END;
IF SY = LPARENT
THEN
BEGIN
REPEAT
INSYMBOL;
IF NXT=NIL
THEN ERROR(554)
ELSE
IF NXT↑.KLASS IN [PROC,FUNC]
THEN
IF SY<>IDENT
THEN ERROR(209)
ELSE
BEGIN
SEARCHID([PROC,FUNC],LCP);
INSYMBOL;
WITH LCP↑ DO
IF PFDECKIND=STANDARD
THEN ERROR(510)
ELSE
BEGIN
IF PFKIND=ACTUAL
THEN LCP1:=NEXT
ELSE LCP1:=FPARAM;
IF COMPPARAM(NXT↑.FPARAM,LCP1)
THEN
IF NXT↑.KLASS<>KLASS
THEN ERROR(503)
ELSE
IF NOT COMPTYPES(IDTYPE,NXT↑.IDTYPE)
THEN ERROR(555)
ELSE
BEGIN
INCREMENT←REGC;
P:=LEVEL-PFLEV;
IF PFKIND=ACTUAL
THEN
IF LANGUAGE<>PASCALSY
THEN ERROR(510)
ELSE
BEGIN
IF P=0
THEN MACRO3(514B(*HRLZ*),REGC,BASIS)
ELSE
IF P=1
THEN MACRO4(514B(*HRLZ*),REGC,BASIS,-1)
ELSE
IF P>1
THEN
BEGIN
MACRO4(550B(*HRRZ*),REGC,BASIS,-1);
FOR I:=3 TO P DO MACRO4(550B(*HRRZ*),REGC,REGC,-1);
MACRO4(514B(*HRLZ*),REGC,REGC,-1)
END;
IF PFADDR=0
THEN
BEGIN
MACRO3(541B(*HRRI*),REGC,LINKCHAIN[P]);
LINKCHAIN[P]:=IC-1;
IF EXTERNDECL
THEN CODE←REFERENCE↑[CIX]:=EXTERNREF
ELSE
CODE←REFERENCE↑[CIX]:=FORWARDREF
END
ELSE MACRO3R(541B(*HRRI*),REGC,PFADDR)
END
ELSE
BEGIN
IF P=0
THEN MACRO4(200B(*MOVE*),REGC,BASIS,PFADDR)
ELSE
BEGIN
MACRO4(200B(*MOVE*),REGC,BASIS,-1);
FOR I:=2 TO P DO MACRO4(200B(*MOVE*),REGC,REGC,-1);
MACRO4(200B(*MOVE*),REGC,REGC,PFADDR)
END
END
END
END
END
ELSE (* NXT↑.KLASS = VARS *)
BEGIN
EXPRESSION(FSYS + [COMMA,RPARENT],ONFIXEDREGC);
IF GATTR.TYPTR <> NIL
THEN
IF NXT <> NIL
THEN
BEGIN
LSP := NXT↑.IDTYPE;
IF LSP <> NIL
THEN
IF NXT↑.VKIND = ACTUAL
THEN
IF LSP↑.SIZE <= 2
THEN
BEGIN
LOAD(GATTR);
IF COMPTYPES(REALPTR,LSP)
THEN MAKEREAL(GATTR)
END
ELSE
BEGIN
IF LSP↑.FORM = FILES
THEN
IF LAST←FILE <> NIL
THEN
IF LAST←FILE↑.NAME = 'TTY '
THEN TTYREAD := TRUE;
LOAD←ADDRESS;
IF FCP↑.LANGUAGE <> PASCALSY
THEN CODE←ARRAY↑.INSTRUCTION[CIX].INSTR := 515B(*HRLZI*)
END
ELSE
WITH GATTR DO
IF KIND = VARBL
THEN LOAD←ADDRESS
ELSE ERROR(463);
IF NOT COMPTYPES(LSP,GATTR.TYPTR)
THEN ERROR(503)
END
END;
IF REGC > FCP↑.HIGHEST←REGISTER
THEN
BEGIN
IF TOPP←OFFSET = 0
THEN
BEGIN
IF FCP↑.PFKIND=FORMAL
THEN TOPP←OFFSET:=FCP↑.PARLISTSIZE+1
ELSE
IF FCP↑.LANGUAGE = PASCALSY
THEN TOPP←OFFSET:=FCP↑.PARLISTSIZE+1
ELSE
BEGIN
TOPP←OFFSET := 1 + FIRST←PARAMETER;
REPEAT
WITH LNXT↑ DO
BEGIN
NUMBER←OF←PARAMETERS := NUMBER←OF←PARAMETERS +1;
TOPP←OFFSET := TOPP←OFFSET + 1;
IF VKIND = ACTUAL
THEN
IF IDTYPE<>NIL
THEN
TOPP←OFFSET := TOPP←OFFSET + IDTYPE↑.SIZE;
LNXT := NEXT
END;
UNTIL LNXT = NIL;
START←OF←PARAMETERLIST := 1 + FIRST←PARAMETER;
ACTUAL←PARAMETER := START←OF←PARAMETERLIST + NUMBER←OF←PARAMETERS
END;
MACRO3(271B(*ADDI*),TOPP,TOPP←OFFSET)
END ;
WITH NXT↑ DO
BEGIN
IF PASCALCALL
THEN
BEGIN
IF KLASS<>VARS
THEN MACRO4(202B(*MOVEM*),REGC,TOPP,PFADDR+1-TOPP←OFFSET)
ELSE
IF (IDTYPE↑.SIZE <> 2) OR (VKIND = FORMAL)
THEN MACRO4(202B(*MOVEM*),REGC,TOPP,VADDR+1-TOPP←OFFSET)
ELSE
BEGIN
MACRO4(202B(*MOVEM*),REGC,TOPP,VADDR+2-TOPP←OFFSET);
IF REGC>FCP↑.HIGHEST←REGISTER+1
THEN
MACRO4(202B(*MOVEM*),REGC-1,TOPP,VADDR+1-TOPP←OFFSET)
END
END
ELSE
BEGIN
IF KLASS<>VARS
THEN ERROR(468)
ELSE
IF VKIND = ACTUAL
THEN
IF IDTYPE<>NIL
THEN
BEGIN
IF IDTYPE↑.SIZE <= 2
THEN
BEGIN
IF IDTYPE↑.SIZE = 2
THEN
BEGIN
MACRO4(202B(*MOVEM*),REGC,TOPP,ACTUAL←PARAMETER+1-TOPP←OFFSET);
REGC := REGC - 1
END;
MACRO4(202B(*MOVEM*),REGC,TOPP,ACTUAL←PARAMETER-TOPP←OFFSET);
MACRO4(541B(*HRRI*),REGC,TOPP,ACTUAL←PARAMETER-TOPP←OFFSET)
END
ELSE
BEGIN
MACRO4(541B(*HRRI*),REGC,TOPP,ACTUAL←PARAMETER-TOPP←OFFSET);
MACRO4(251B(*BLT*),REGC,TOPP,ACTUAL←PARAMETER+IDTYPE↑.SIZE-1-TOPP←OFFSET)
END;
ACTUAL←PARAMETER := ACTUAL←PARAMETER + IDTYPE↑.SIZE
END;
MACRO4(552B(*HRRZM*),REGC,TOPP,START←OF←PARAMETERLIST-TOPP←OFFSET);
START←OF←PARAMETERLIST := START←OF←PARAMETERLIST + 1
END;
REGC := FCP↑.HIGHEST←REGISTER
END
END; (*REGC>FCP↑.HIGHEST←REGISTER*)
IF NXT <> NIL
THEN NXT := NXT↑.NEXT;
SKIPIFERR([COMMA,RPARENT],256,FSYS)
UNTIL SY <> COMMA;
IF SY = RPARENT
THEN INSYMBOL
ELSE ERROR(152)
END (*IF LPARENT*);
IF NXT<>NIL
THEN ERROR(554);
FOR I := 0 TO WITHIX DO
WITH DISPLAY[TOP-I] DO
IF (CINDR<>0) AND (CINDR<>BASIS)
THEN MACRO4(202B(*MOVEM*),CINDR,BASIS,CLC);
WITH FCP↑ DO
BEGIN
IF LKIND=FORMAL
THEN
BEGIN
IF TOPP←OFFSET<>0
THEN MACRO3(275B(*SUBI*),TOPP,TOPP←OFFSET)
END
ELSE
IF (LANGUAGE = PASCALSY) AND (TOPP←OFFSET <> 0)
THEN MACRO3(275B(*SUBI*),TOPP,TOPP←OFFSET)
ELSE
IF (LANGUAGE <> PASCALSY) AND (TOPP←OFFSET = 0)
THEN
BEGIN
TOPP←OFFSET:= FIRST←PARAMETER+2;
MACRO3(271B(*ADDI*),TOPP,TOPP←OFFSET)
END;
IF PFLEV > 1
THEN P := LEVEL - PFLEV
ELSE P:= 0;
IF LKIND = ACTUAL
THEN
BEGIN
IF LANGUAGE <> PASCALSY
THEN
BEGIN
MACRO3(515B(*HRLZI*),REG0,-NUMBER←OF←PARAMETERS);
MACRO4(202B(*MOVEM*),REG0,TOPP,FIRST←PARAMETER-TOPP←OFFSET);
MACRO4(202B(*MOVEM*),BASIS,TOPP,-TOPP←OFFSET);
MACRO4(551B(*HRRZI*),BASIS,TOPP,FIRST←PARAMETER-TOPP←OFFSET+1);
IF NUMBER←OF←PARAMETERS = 0
THEN MACRO4(402B(*SETZM*),0,TOPP,FIRST←PARAMETER-TOPP←OFFSET+1)
END;
IF PFADDR = 0
THEN
BEGIN
MACRO3R(260B(*PUSHJ*),TOPP,LINKCHAIN[P]); LINKCHAIN[P]:= IC-1;
IF EXTERNDECL
THEN CODE←REFERENCE↑[CIX] := EXTERNREF
ELSE CODE←REFERENCE↑[CIX] := FORWARDREF
END
ELSE MACRO3R(260B(*PUSHJ*),TOPP,PFADDR-P);
IF LANGUAGE <> PASCALSY
THEN
BEGIN
MACRO3(275B(*SUBI*),TOPP,TOPP←OFFSET);
IF KLASS = FUNC
THEN
BEGIN
MACRO4(202B(*MOVEM*),REG0,TOPP,2);
IF IDTYPE↑.SIZE = 2
THEN MACRO4(202B(*MOVEM*),REG1,TOPP,3)
END;
MACRO4(200B(*MOVE*),BASIS,TOPP,0)
END;
END
ELSE (*LKIND=FORMAL*)
BEGIN
IF P=0
THEN
BEGIN
MACRO4(550B(*HRRZ*),REG1,BASIS,PFADDR);
MACRO4(544B(*HLR*),BASIS,BASIS,PFADDR)
END
ELSE
BEGIN
MACRO4(550B(*HRRZ*),REG1,BASIS,-1);
FOR I:=2 TO P DO MACRO4(550B(*HRRZ*),REG1,REG1,-1);
MACRO4(544B(*HLR*),BASIS,REG1,PFADDR);
MACRO4(550B(*HRRZ*),REG1,REG1,PFADDR)
END;
MACRO4(260B(*PUSHJ*),TOPP,REG1,0)
END
END;
FOR I := 0 TO WITHIX DO
WITH DISPLAY[TOP-I] DO
IF (CINDR<>0) AND (CINDR<>BASIS)
THEN MACRO4(200B(*MOVE*),CINDR,BASIS,CLC) ;
IF SAVE←COUNT > 0
THEN
BEGIN
IF SAVE←COUNT > 3
THEN
BEGIN
MACRO4(515B(*HRLZI*),REG1,BASIS,LLC);
MACRO3(541B(*HRRI*),REG1,2);
MACRO3(251B(*BLT*),REG1,SAVE←COUNT+1)
END
ELSE FOR I := 1 TO SAVE←COUNT DO MACRO4(200B(*MOVE*),REGIN+I,BASIS,LLC+I-1) ;
LC := LLC
END ;
GATTR.TYPTR := FCP↑.IDTYPE; REGC := LREGC
END (*CALL←NON←STANDARD*) ;
BEGIN
(*CALL*)
NOLOAD := FALSE;
TTY←MESSAGE := FALSE;
BUFFER←VARIABLE := FALSE;
IF FCP↑.PFDECKIND = STANDARD
THEN
BEGIN
LKEY := FCP↑.KEY; LCLASS := FCP↑.KLASS;
IF FCP↑.KLASS = PROC
THEN
BEGIN
IF NOT (LKEY IN [1..11,17,19,25..27,29])
THEN
IF SY = LPARENT
THEN INSYMBOL
ELSE ERROR(153);
FSYS := FSYS + [RPARENT];
IF (LKEY IN [5..8,10,11,26..29]) AND (REGCMAX <= 8) (*<--- REG2..8 USED BY RUNTIME-SUPPORT*)
THEN ERROR(317);
CASE LKEY OF
1,2,3,4,
5,6:
GETPUTRESETREWRITE;
7,
8:
BEGIN
READREADLN;
IF NO←RIGHT←PARENT
THEN GOTO 666
END;
9:
BEGIN
BREAK ;
IF NO←RIGHT←PARENT
THEN GOTO 666
END ;
10,
11:
BEGIN
WRITEWRITELN;
IF NO←RIGHT←PARENT
THEN GOTO 666
END;
12,
13:
PACKUNPACK;
24,
14:
NEWDISPOSE;
17:
BEGIN
NOLOAD := TRUE;
GETLINENR
END;
19:
BEGIN
PAGE;
IF NO←RIGHT←PARENT
THEN GOTO 666
END;
20:
PROTECTION;
21:
CALL;
22:
DATE;
23:
TIME;
25:
BEGIN
HALT;
GOTO 666
END;
28:
MESSAGE;
OTHERS:
ERRANDSKIP(169,FSYS)
END
END
ELSE
BEGIN
IF LKEY IN [2..9,13..16,19..22]
THEN
BEGIN
IF SY = LPARENT
THEN INSYMBOL
ELSE ERROR(153);
IF LKEY IN [2..9,13,14,18]
THEN
EXPRESSION(FSYS + [RPARENT,COMMA],ONREGC);
IF LKEY IN [3..5,8,9,13,14,18]
THEN LOAD(GATTR)
END;
CASE LKEY OF
1:
REALTIME;
2:
ABS;
3:
SQR;
5:
ODD;
6:
ORD;
7:
CHR;
8,9:
PREDSUCC;
10,11:
BEGIN
NOLOAD := TRUE;
EOFEOLN;
IF NO←RIGHT←PARENT
THEN GOTO 666
END;
12:
CLOCK;
13:
CARD;
15,16:
LOWERUPPERBOUND;
19,20:
MINMAX;
21,22:
FIRSTLAST;
OTHERS:
ERRANDSKIP(169,FSYS + [RPARENT])
END;
IF LKEY IN [1,12]
THEN GOTO 666
END;
IF SY = RPARENT
THEN INSYMBOL
ELSE ERROR(152);
666:
END (*STANDARD PROCEDURES AND FUNCTIONS*)
ELSE CALL←NON←STANDARD
END (*CALL*) ;
PROCEDURE EXPRESSION;
VAR
JUMP←OFFSET: 2..4;
DEFAULT←OFFSET: 4..5;
LATTR: ATTR;
LOP: OPERATOR;
LSIZE: ADDRRANGE;
DEFAULT,JUMP: BOOLEAN;
BOOLREGC,TESTREGC,LREGC1,LREGC2:ACRANGE;
LINSTR,LINSTR1: INSTRANGE;
SETINCLUSION : BOOLEAN;
JMPADRIFALLEQUAL : INTEGER;
PROCEDURE CHANGEBOOL(VAR FINSTR: INSTRANGE);
BEGIN
IF (FINSTR>=311B) AND (FINSTR<=313B)
THEN FINSTR := FINSTR+4 (*CAML,CAME,CAMLE --> CAMGE,CAMN,CAMG*)
ELSE
IF (FINSTR>=315B) AND (FINSTR<=317B)
THEN FINSTR := FINSTR-4 (*SAME IN THE OTHER WAY*)
END;
PROCEDURE SEARCHCODE(FINSTR:INSTRANGE; FATTR: ATTR);
PROCEDURE CHANGEOPERANDS(VAR FINSTR:INSTRANGE);
BEGIN
IF FINSTR=311B(*CAML*)
THEN FINSTR := 317B(*CAMG*)
ELSE
IF FINSTR = 313B(*CAMLE*)
THEN FINSTR := 315B(*CAMGE*)
ELSE
IF FINSTR=315B(*CAMGE*)
THEN FINSTR := 313B(*CAMLE*)
ELSE
IF FINSTR = 317B(*CAMG*)
THEN FINSTR := 311B(*CAML*)
ELSE
IF FINSTR = 420B(*ANDCM*)
THEN FINSTR := 410B(*ANDCA*)
ELSE
IF FINSTR = 410B(*ANDCA*)
THEN FINSTR := 420B(*ANDCM*)
END;
BEGIN
WITH GATTR DO
IF FATTR.KIND = EXPR
THEN
BEGIN
GENERATE←CODE(FINSTR,FATTR.REG,GATTR); REG := FATTR.REG
END
ELSE
IF KIND = EXPR
THEN
BEGIN
CHANGEOPERANDS(FINSTR); GENERATE←CODE(FINSTR,REG,FATTR)
END
ELSE
IF (KIND=VARBL) AND ((PACKFG<>NOTPACK)
OR (INDEXR>REGIN) AND (INDEXR<=REGCMAX) AND
((FATTR.INDEXR<=REGIN) OR (FATTR.INDEXR>REGCMAX)))
THEN
BEGIN
LOAD(GATTR); CHANGEOPERANDS(FINSTR); GENERATE←CODE(FINSTR,REG,FATTR)
END
ELSE
BEGIN
LOAD(FATTR); GENERATE←CODE(FINSTR,FATTR.REG,GATTR); REG := FATTR.REG
END
END;
PROCEDURE SIMPLEEXPRESSION(FSYS: SETOFSYS);
VAR
LATTR: ATTR; LOP: OPERATOR; SIGNED : BOOLEAN;
PROCEDURE TERM(FSYS: SETOFSYS);
VAR
LATTR: ATTR; LOP: OPERATOR;
PROCEDURE FACTOR(FSYS: SETOFSYS);
VAR
LCP: CTP; LVP: CSP; VARPART: BOOLEAN;
CSTPART: SET OF SETRANGE; LSP: STP;
RANGEPART: BOOLEAN; LRMIN: SETRANGE;
LOFFSET: 0..OFFSET ;
BEGIN
IF NOT (SY IN FACBEGSYS)
THEN
BEGIN
ERRANDSKIP(173,FSYS + FACBEGSYS);
GATTR.TYPTR := NIL
END;
IF SY IN FACBEGSYS
THEN
BEGIN
CASE SY OF
IDENT:
BEGIN
SEARCHID([KONST,VARS,FIELD,FUNC],LCP);
INSYMBOL;
CASE LCP↑.KLASS OF
FUNC:
BEGIN
CALL(FSYS,LCP);
IF LCP↑.PFDECKIND=DECLARED
THEN
BEGIN
WITH LCP↑,GATTR DO
BEGIN
TYPTR :=IDTYPE; KIND :=VARBL; PACKFG :=NOTPACK;
VRELBYTE := NO;
VLEVEL :=1; DPLMT :=2;
INDEXR := TOPP; INDBIT :=0;
IF TYPTR <> NIL
THEN
IF TYPTR↑.SIZE = 1
THEN LOAD(GATTR)
END
END
END;
KONST:
WITH GATTR, LCP↑ DO
BEGIN
TYPTR := IDTYPE; KIND := CST;
CVAL := VALUES
END;
OTHERS:
SELECTOR(FSYS,LCP)
END (*CASE KLASS*);
IF GATTR.TYPTR <> NIL
THEN WITH GATTR, TYPTR↑ DO
IF FORM = SUBRANGE (*ELIMINATE SUBRANGE TYPES*)
THEN TYPTR := RANGETYPE (*TO SIMPLIFY LATER TESTS*)
END;
INTCONST:
BEGIN
WITH GATTR DO
BEGIN
TYPTR := INTPTR; KIND := CST;
CVAL := VAL
END;
INSYMBOL
END;
REALCONST:
BEGIN
WITH GATTR DO
BEGIN
TYPTR := REALPTR; KIND := CST;
CVAL := VAL
END;
INSYMBOL
END;
STRINGCONST:
BEGIN
WITH GATTR DO
BEGIN
CONSTANT(FSYS,TYPTR,CVAL) ; KIND := CST
END
END;
LPARENT:
BEGIN
INSYMBOL; EXPRESSION(FSYS + [RPARENT],ONREGC);
IF SY = RPARENT
THEN INSYMBOL
ELSE ERROR(152)
END;
NOTSY:
BEGIN
INSYMBOL; FACTOR(FSYS);
IF GATTR.TYPTR = BOOLPTR
THEN
BEGIN
LOAD(GATTR); MACRO3(411B(*ANDCAI*),REGC,1)
END
ELSE
BEGIN
ERROR(359); GATTR.TYPTR := NIL
END
END;
LBRACK:
BEGIN
INSYMBOL; CSTPART := [ ]; VARPART := FALSE;
RANGEPART:=FALSE;
NEW(LSP,POWER);
WITH LSP↑ DO
BEGIN
ELSET:=NIL; SIZE:= 2
END;
IF SY = RBRACK
THEN
BEGIN
WITH GATTR DO
BEGIN
TYPTR:=LSP; KIND:=CST;
NEW(LVP,PSET); LVP↑.PVAL := CSTPART; CVAL.VALP := LVP
END;
INSYMBOL
END
ELSE
BEGIN
LOOP
INCREMENT←REGC; INCREMENT←REGC;
EXPRESSION(FSYS + [COMMA,RBRACK,COLON],ONREGC);
IF GATTR.TYPTR <> NIL
THEN
IF GATTR.TYPTR↑.FORM <> SCALAR
THEN
BEGIN
ERROR(461); GATTR.TYPTR := NIL
END
ELSE
IF COMPTYPES(LSP↑.ELSET,GATTR.TYPTR)
THEN
WITH GATTR DO
BEGIN
IF KIND = CST
THEN
BEGIN
IF COMPTYPES(TYPTR,ASCIIPTR)
THEN CVAL.IVAL := CVAL.IVAL-OFFSET;
IF (CVAL.IVAL < 0) OR (CVAL.IVAL > BASEMAX)
THEN ERROR(268)
ELSE CSTPART := CSTPART + [CVAL.IVAL];
REGC := REGC - 2;
IF SY=COLON
THEN
BEGIN
RANGEPART:=TRUE;
LRMIN:=CVAL.IVAL
END
ELSE
IF RANGEPART
THEN
BEGIN
LRMIN:=LRMIN+1;
WHILE (LRMIN<CVAL.IVAL) DO
BEGIN
CSTPART:=CSTPART + [LRMIN];
LRMIN:=LRMIN+1
END;
RANGEPART:=FALSE
END
END
ELSE
BEGIN
IF (SY=COLON) OR RANGEPART
THEN
BEGIN
ERROR(207);RANGEPART := NOT RANGEPART
END;
LOAD(GATTR);
REGC := REGC -1;
MACRO3(515B(*HRLZI*),REGC-1,400000B);
MACRO2(400B(*SETZ*),REGC);
IF RUNTIME←CHECK
THEN
BEGIN
IF COMPTYPES(TYPTR,ASCIIPTR)
THEN LOFFSET := OFFSET
ELSE LOFFSET := 0 ;
MACRO3(301B(*CAIL*),REGC+1,LOFFSET);
MACRO3(303B(*CAILE*),REGC+1,BASEMAX+LOFFSET);
SUPPORT(ERRORINSET)
END;
MACRO3(210B(*MOVN*),REGC+1,REGC+1);
IF COMPTYPES(TYPTR,ASCIIPTR)
THEN MACRO4(246B(*LSHC*),REGC-1,REGC+1,OFFSET)
ELSE MACRO4(246B(*LSHC*),REGC-1,REGC+1,0);
IF VARPART
THEN
BEGIN
MACRO3(434B(*IOR*),REGC-3,REGC-1);
MACRO3(434B(*IOR*),REGC-2,REGC);
REGC := REGC - 2
END
ELSE VARPART := TRUE;
KIND := EXPR; REG := REGC
END;
LSP↑.ELSET := TYPTR;
TYPTR :=LSP
END
ELSE ERROR(360)
EXIT IF NOT(SY IN [COMMA,COLON]);
INSYMBOL
END;
IF SY = RBRACK
THEN INSYMBOL
ELSE ERROR(155);
IF VARPART
THEN
BEGIN
IF CSTPART <> [ ]
THEN
BEGIN
NEW(LVP,PSET); LVP↑.PVAL := CSTPART;
GATTR.KIND := CST; GATTR.CVAL.VALP := LVP;
GENERATE←CODE(434B(*IOR*),REGC,GATTR)
END
END
ELSE
BEGIN
NEW(LVP,PSET); LVP↑.PVAL := CSTPART; GATTR.CVAL.VALP := LVP
END
END
END
END (*CASE*) ;
IFERRSKIP(166,FSYS)
END (*IF SY IN FACBEGSYS*)
END (*FACTOR*) ;
BEGIN
(*TERM*)
FACTOR(FSYS + [MULOP]);
WHILE SY = MULOP DO
BEGIN
IF OP IN [RDIV,IDIV,IMOD]
THEN LOAD(GATTR); (*BECAUSE OPERANDS ARE NOT
ALLOWED TO BE CHOSEN*)
LATTR := GATTR; LOP := OP;
INSYMBOL; FACTOR(FSYS + [MULOP]);
IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL)
THEN
CASE LOP OF
MUL:
IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
AND (GATTR.TYPTR↑.FORM = POWER)
THEN SEARCHCODE(404B(*AND*),LATTR)
ELSE
IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR)
THEN SEARCHCODE(220B(*IMUL*),LATTR)
ELSE
BEGIN
MAKEREAL(LATTR);
IF (LATTR.TYPTR = REALPTR) AND (GATTR.TYPTR = REALPTR)
THEN SEARCHCODE(164B(*FMPR*),LATTR)
ELSE
BEGIN
ERROR(311); GATTR.TYPTR := NIL
END
END;
RDIV:
BEGIN
MAKEREAL(LATTR);
IF (LATTR.TYPTR = REALPTR) AND (GATTR.TYPTR = REALPTR)
THEN SEARCHCODE(174B(*FDVR*),LATTR)
ELSE
BEGIN
ERROR(311); GATTR.TYPTR := NIL
END
END;
IDIV:
IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR)
THEN SEARCHCODE(230B(*IDIV*),LATTR)
ELSE
BEGIN
ERROR(311); GATTR.TYPTR := NIL
END;
IMOD:
IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR)
THEN
BEGIN
SEARCHCODE(230B(*IDIV*),LATTR);GATTR.REG := GATTR.REG+1
END
ELSE
BEGIN
ERROR(311); GATTR.TYPTR := NIL
END;
ANDOP:
IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
AND (GATTR.TYPTR = BOOLPTR)
THEN SEARCHCODE(404B(*AND*),LATTR)
ELSE
BEGIN
ERROR(311); GATTR.TYPTR := NIL
END
END (*CASE*)
ELSE GATTR.TYPTR := NIL;
REGC:=GATTR.REG
END (*WHILE*)
END (*TERM*) ;
BEGIN
(*SIMPLEEXPRESSION*)
SIGNED := FALSE;
IF (SY = ADDOP) AND (OP IN [PLUS,MINUS])
THEN
BEGIN
SIGNED := OP = MINUS; INSYMBOL
END;
TERM(FSYS + [ADDOP]);
IF SIGNED
THEN WITH GATTR DO
IF TYPTR <> NIL
THEN
IF (TYPTR = INTPTR) OR (TYPTR = REALPTR)
THEN
CASE KIND OF
CST:
IF TYPTR = INTPTR
THEN CVAL.IVAL := - CVAL.IVAL
ELSE
BEGIN
INCREMENT←REGC;
GENERATE←CODE(210B(*MOVN*),REGC,GATTR)
END;
VARBL:
BEGIN
INCREMENT←REGC;
GENERATE←CODE(210B(*MOVN*),REGC,GATTR)
END;
EXPR:
MACRO3(210B(*MOVN*),REG,REG)
END (*CASE*)
ELSE
BEGIN
ERROR(311) ; GATTR.TYPTR := NIL
END ;
WHILE SY = ADDOP DO
BEGIN
IF AOS = B2
THEN
IF (LEFTSIDE.PACKFG=NOTPACK) AND COMPTYPES(LEFTSIDE.TYPTR,INTPTR)
THEN
BEGIN
LEFTSIDE.TYPTR:=INTPTR; LEFTSIDE.BPADDR:=GATTR.BPADDR;
IF LEFTSIDE=GATTR
THEN AOS := B3
ELSE AOS:=B0
END
ELSE AOS := B0
ELSE AOS := B0;
IF OP=MINUS
THEN LOAD(GATTR); (*BECAUSE OPD MAY NOT BE CHOSEN*)
LATTR := GATTR; LOP := OP;
INSYMBOL; TERM(FSYS + [ADDOP]);
IF AOS=B3
THEN
IF GATTR.KIND<>CST
THEN AOS:=B0;
IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL)
THEN
CASE LOP OF
PLUS:
IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
AND (GATTR.TYPTR↑.FORM = POWER)
THEN SEARCHCODE(434B(*IOR*),LATTR)
ELSE
IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR)
THEN
BEGIN
IF AOS=B3
THEN
IF GATTR.CVAL.IVAL=1
THEN AOS := AOSINSTR;
SEARCHCODE(270B(*ADD*),LATTR)
END
ELSE
BEGIN
MAKEREAL(LATTR);
IF (LATTR.TYPTR=REALPTR) AND (GATTR.TYPTR=REALPTR)
THEN SEARCHCODE(144B(*FADR*),LATTR)
ELSE
BEGIN
ERROR(311); GATTR.TYPTR := NIL
END
END;
MINUS:
IF (LATTR.TYPTR=INTPTR) AND (GATTR.TYPTR=INTPTR)
THEN
BEGIN
IF AOS=B3
THEN
IF GATTR.CVAL.IVAL=1
THEN AOS := SOSINSTR;
SEARCHCODE(274B(*SUB*),LATTR)
END
ELSE
BEGIN
MAKEREAL(LATTR);
IF (LATTR.TYPTR = REALPTR) AND (GATTR.TYPTR = REALPTR)
THEN SEARCHCODE(154B(*FSBR*),LATTR)
ELSE
IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
AND (LATTR.TYPTR↑.FORM = POWER)
THEN SEARCHCODE(420B(*ANDCM*),LATTR)
ELSE
BEGIN
ERROR(311); GATTR.TYPTR := NIL
END
END;
OROP:
IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
AND (GATTR.TYPTR = BOOLPTR)
THEN SEARCHCODE(434B(*IOR*),LATTR)
ELSE
BEGIN
ERROR(311); GATTR.TYPTR := NIL
END
END (*CASE*)
ELSE GATTR.TYPTR := NIL;
REGC:=GATTR.REG;
IF AOS <= B3
THEN AOS := B0
END (*WHILE*);
IF AOS <= B3
THEN AOS := B0
END (*SIMPLEEXPRESSION*) ;
BEGIN
(*EXPRESSION*)
TESTREGC := REGC+1;
IF AOS=B1
THEN AOS:=B2
ELSE AOS:=B0;
SIMPLEEXPRESSION(FSYS + [RELOP]);
IF SY = RELOP
THEN
BEGIN
JUMP := FALSE;
IF FVALUE IN [ONREGC,ONFIXEDREGC]
THEN
BEGIN
INCREMENT←REGC; MACRO3(551B(*HRRZI*),REGC,1); BOOLREGC := REGC
END;
IF GATTR.TYPTR <> NIL
THEN
IF GATTR.TYPTR↑.SIZE > 2
THEN LOAD←ADDRESS;
LREGC1 := REGC;
LATTR := GATTR;
LOP := OP;
IF (FVALUE IN [ONREGC,ONFIXEDREGC]) AND (REGC < BOOLREGC)
THEN REGC := BOOLREGC;
INSYMBOL; SIMPLEEXPRESSION(FSYS);
IF GATTR.TYPTR <> NIL
THEN
IF GATTR.TYPTR↑.SIZE > 2
THEN LOAD←ADDRESS; LREGC2 := REGC;
IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL)
THEN
BEGIN
IF LOP = INOP
THEN
IF GATTR.TYPTR↑.FORM = POWER
THEN
IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR↑.ELSET)
THEN
BEGIN
LOAD(LATTR);
IF (FVALUE IN [ONREGC,ONFIXEDREGC]) AND (REGC < BOOLREGC)
THEN REGC := BOOLREGC;
LOAD(GATTR); REGC := GATTR.REG - 1;
IF COMPTYPES(LATTR.TYPTR,ASCIIPTR)
THEN MACRO4(246B(*LSHC*),REGC,LATTR.REG,-OFFSET)
ELSE MACRO4(246B(*LSHC*),REGC,LATTR.REG,0);
IF FVALUE = TRUEJMP
THEN LINSTR := 305B(*CAIGE*)
ELSE LINSTR := 301B(*CAIL*);
MACRO2(LINSTR,REGC)
END
ELSE
BEGIN
ERROR(260); GATTR.TYPTR := NIL
END
ELSE
BEGIN
ERROR(213); GATTR.TYPTR := NIL
END
ELSE
BEGIN
IF LATTR.TYPTR <> GATTR.TYPTR
THEN MAKEREAL(LATTR);
IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
THEN
BEGIN
LSIZE := LATTR.TYPTR↑.SIZE;
CASE LATTR.TYPTR↑.FORM OF
POWER:
IF LOP IN [LTOP,GTOP]
THEN ERROR(313);
ARRAYS:
IF NOT STRING(LATTR.TYPTR)
AND (LOP IN [LTOP,LEOP,GTOP,GEOP])
THEN ERROR(312);
POINTER,
RECORDS:
IF LOP IN [LTOP,LEOP,GTOP,GEOP]
THEN ERROR(312);
FILES:
ERROR(314)
END;
WITH LATTR.TYPTR↑ DO
BEGIN
IF SIZE <= 2
THEN
BEGIN
DEFAULT := TRUE;
SETINCLUSION := FALSE;
JUMP←OFFSET := 3;
DEFAULT←OFFSET := 4;
CASE LOP OF
LTOP:
BEGIN
LINSTR := 311B(*CAML*); LINSTR1 := 313B
END;
LEOP:
IF FORM = POWER
THEN
BEGIN
SEARCHCODE(420B(*ANDCM*),LATTR);
SETINCLUSION := TRUE
END
ELSE
BEGIN
LINSTR := 313B(*CAMLE*); LINSTR1 := 313B
END;
GTOP:
BEGIN
LINSTR := 317B(*CAMG*); LINSTR1 := 315B
END;
GEOP:
IF FORM = POWER
THEN
BEGIN
SEARCHCODE(410B(*ANDCA*),LATTR);
SETINCLUSION := TRUE
END
ELSE
BEGIN
LINSTR := 315B(*CAMGE*); LINSTR1 := 315B
END;
NEOP:
BEGIN
LINSTR := 316B(*CAMN*);DEFAULT := FALSE
END;
EQOP:
BEGIN
LINSTR := 312B(*CAME*); DEFAULT := FALSE
END
END;
IF FVALUE IN [TRUEJMP,FALSEJMP]
THEN
BEGIN
IF (FORM = SCALAR) AND (GATTR.KIND = CST)
THEN
IF LATTR.TYPTR = REALPTR
THEN JUMP := GATTR.CVAL.VALP↑.RVAL = 0.0
ELSE
IF GATTR.CVAL.IVAL = 0
THEN JUMP := TRUE;
IF (FVALUE = TRUEJMP) <> JUMP
THEN CHANGEBOOL(LINSTR);
IF JUMP
THEN LINSTR := LINSTR + 10B (*E.G CAML --> JUMPL *)
END;
IF SIZE = 1
THEN
IF JUMP
THEN
BEGIN
LOAD(LATTR); MACRO3(LINSTR,LATTR.REG,0)
END
ELSE SEARCHCODE(LINSTR,LATTR)
ELSE
IF SETINCLUSION
THEN
BEGIN
MACRO3(336B(*SKIPN*),0,GATTR.REG);
MACRO3(332B(*SKIPE*),0,GATTR.REG-1);
IF FVALUE = TRUEJMP
THEN MACRO3R(254B(*JRST*),0,IC+2)
END
ELSE
BEGIN
LOAD(LATTR);
IF (FVALUE IN [ONREGC,ONFIXEDREGC]) AND (REGC<BOOLREGC)
THEN REGC := BOOLREGC;
LOAD(GATTR);
CASE FVALUE OF
ONREGC,
ONFIXEDREGC,
FALSEJMP:
IF LOP = EQOP
THEN JUMP←OFFSET := 2;
TRUEJMP:
IF LOP <> EQOP
THEN
BEGIN
JUMP←OFFSET := 2; DEFAULT←OFFSET := 5
END
END;
IF DEFAULT
THEN
BEGIN
MACRO3(LINSTR1,LATTR.REG-1,GATTR.REG-1);
MACRO3R(254B(*JRST*),0,IC + DEFAULT←OFFSET)
END;
MACRO3(312B(*CAME*),LATTR.REG-1,GATTR.REG-1);
MACRO3R(254B(*JRST*),0,IC+JUMP←OFFSET);
MACRO3(LINSTR,LATTR.REG,GATTR.REG)
END
END
ELSE
BEGIN
MACRO3(551B(*HRRZI*),REG0,LSIZE);
INCREMENT←REGC ;
MACRO4(200B(*MOVE*),REGC,LREGC1,0);
MACRO4(312B(*CAME*),REGC,LREGC2,0);
MACRO3R(254B(*JRST*),0,IC+5);
MACRO2(340B(*AOJ*),LREGC1);
MACRO2(340B(*AOJ*),LREGC2);
MACRO3R(367B(*SOJG*),REG0,IC-5);
JMPADRIFALLEQUAL := 0;
CASE LOP OF
LTOP,GTOP:
IF FVALUE=TRUEJMP
THEN JMPADRIFALLEQUAL := 3
ELSE JMPADRIFALLEQUAL := 2;
LEOP,GEOP:
IF FVALUE=TRUEJMP
THEN JMPADRIFALLEQUAL := 2
ELSE JMPADRIFALLEQUAL := 3;
EQOP :
IF FVALUE<>TRUEJMP
THEN JMPADRIFALLEQUAL := 2;
NEOP :
IF FVALUE=TRUEJMP
THEN JMPADRIFALLEQUAL := 2
END;
IF JMPADRIFALLEQUAL <> 0
THEN MACRO4R(254B(*JRST*),0,0,IC+JMPADRIFALLEQUAL);
CASE LOP OF
LTOP,LEOP:
LINSTR := 311B(*CAML*);
GTOP,GEOP:
LINSTR := 317B(*CAMG*)
END;
IF FVALUE=TRUEJMP
THEN CHANGEBOOL(LINSTR);
IF LOP IN [LTOP,LEOP,GTOP,GEOP]
THEN MACRO4(LINSTR,REGC,LREGC2,0);
REGC:=REGC-2
END
END
END
ELSE ERROR(260)
END;
IF FVALUE IN [ONREGC,ONFIXEDREGC]
THEN
BEGIN
MACRO3(400B(*SETZ*),BOOLREGC,0); REGC := BOOLREGC
END
ELSE
IF NOT JUMP
THEN MACRO3(254B(*JRST*),0,0)
END;
GATTR.TYPTR := BOOLPTR; GATTR.KIND := EXPR; GATTR.REG := REGC
END (*SY = RELOP*)
ELSE
IF FVALUE IN [TRUEJMP,FALSEJMP]
THEN
BEGIN
LOAD(GATTR);
IF GATTR.TYPTR<>BOOLPTR
THEN ERROR (359);
IF FVALUE = TRUEJMP
THEN LINSTR := 326B(*JUMPN*)
ELSE LINSTR := 322B(*JUMPE*);
MACRO3(LINSTR,GATTR.REG,0)
END
ELSE
IF GATTR.KIND=EXPR
THEN REGC := GATTR.REG;
IF FVALUE = ONFIXEDREGC
THEN WITH GATTR DO
IF (TYPTR <> NIL) AND (KIND=EXPR)
THEN WITH TYPTR↑ DO
BEGIN
IF SIZE = 2
THEN TESTREGC := TESTREGC + 1;
IF TESTREGC <> REGC
THEN
BEGIN
IF SIZE = 2
THEN MACRO3(200B(*MOVE*),TESTREGC-1,REGC-1);
MACRO3(200B(*MOVE*),TESTREGC,REGC); REGC := TESTREGC;REG := REGC
END
END
END (*EXPRESSION*) ;
PROCEDURE ASSIGNMENT(FCP: CTP);
VAR
SLATTR: ATTR;
CMIN, CMAX: VALU;
LEFTSIDE←REAL: BOOLEAN;
LINSTR: INSTRANGE;
OLDIX: CODERANGE;
OLDIC: ADDRRANGE;
PROCEDURE STOREGLOBALS ;
TYPE
CHANGEFORM = (PTRW,INTW,REELW,PSETW,STRGW,INSTW) ;
VAR
CHANGE : RECORD
CASE KW : CHANGEFORM OF
PTRW: (WPTR :GTP (*TO ALLOW NIL*)) ;
INTW: (WINT : INTEGER ; WINT1 : INTEGER (*TO PICK UP SECOND WORD OF SET*)) ;
REELW: (WREEL: REAL) ;
PSETW: (WSET : SET OF SETRANGE) ;
STRGW: (WSTRG: CHARWORD) ;
INSTW: (WINST: PDP10INSTR)
END ;
I: 1..STRGLGTH; J: 0..5;
PROCEDURE STOREWORD ;
BEGIN
CIX := CIX + 1 ;
IF CIX > CODE←SIZE
THEN
BEGIN
CIX := 0;
IF NOT OVERRUN
THEN
BEGIN
OVERRUN := TRUE;
ERROR←WITH←TEXT(356,'INITPROCD.')
END
END ;
WITH CGLOBPTR↑ DO
BEGIN
CODE←ARRAY↑.INSTRUCTION[CIX] := CHANGE.WINST ;
LASTGLOB := LASTGLOB + 1
END
END (*STOREWORD*) ;
PROCEDURE GETNEWGLOBPTR ;
VAR
LGLOBPTR : GTP ;
BEGIN
NEW(LGLOBPTR) ;
WITH LGLOBPTR↑ DO
BEGIN
NEXTGLOBPTR := NIL ;
FIRSTGLOB := 0
END ;
IF CGLOBPTR <> NIL
THEN CGLOBPTR↑.NEXTGLOBPTR := LGLOBPTR ;
CGLOBPTR := LGLOBPTR
END (*GETNEWGLOBPTR*);
BEGIN
(*STOREGLOBALS*)
IF FGLOBPTR = NIL
THEN
BEGIN
GETNEWGLOBPTR ;
FGLOBPTR := CGLOBPTR
END
ELSE
IF LEFTSIDE.DPLMT <> CGLOBPTR↑.LASTGLOB + 1
THEN GETNEWGLOBPTR ;
WITH CHANGE,CGLOBPTR↑,GATTR,CVAL DO
BEGIN
IF FIRSTGLOB = 0
THEN
BEGIN
IF LEFTSIDE.PACKFG<>NOTPACK
THEN
IF ERRLIST[ERRINX].ARW<>507
THEN ERROR(507);
FIRSTGLOB := LEFTSIDE.DPLMT ;
LASTGLOB := FIRSTGLOB - 1 ;
FCIX := CIX + 1
END ;
CASE TYPTR↑.FORM OF
SCALAR,
SUBRANGE:
BEGIN
IF LEFTSIDE←REAL
THEN
IF TYPTR=INTPTR
THEN WREEL := IVAL
ELSE WREEL := VALP↑.RVAL
ELSE WINT := IVAL ;
STOREWORD
END ;
POINTER :
BEGIN
WPTR := NIL ; STOREWORD
END ;
POWER :
BEGIN
WSET := VALP↑.PVAL ; STOREWORD ;
WINT := WINT1 (*GET SECOND WORD OF SET*) ;
STOREWORD
END ;
ARRAYS :
WITH VALP↑,CHANGE DO
BEGIN
J := 0; WINT := 0;
FOR I := 1 TO SLGTH DO
BEGIN
J := J + 1;
WSTRG[J] := SVAL[I];
IF J=5
THEN
BEGIN
J := 0;
STOREWORD; WINT := 0
END
END;
IF J<>0
THEN STOREWORD
END;
OTHERS :
ERROR(411)
END (*CASE*)
END (* WITH *)
END (* STOREGLOBALS *) ;
BEGIN
(*ASSIGNMENT*)
SELECTOR(FSYS + [BECOMES],FCP);
IF SY = BECOMES
THEN
BEGIN
LEFTSIDE := GATTR;
LEFTSIDE←REAL := COMPTYPES(LEFTSIDE.TYPTR,REALPTR);
IF NOT RUNTIME←CHECK
THEN
BEGIN
AOS := B1; OLDIX:=CIX; OLDIC:=IC
END;
INSYMBOL;
EXPRESSION(FSYS,ONREGC);
IF (LEFTSIDE.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL)
THEN
IF COMPTYPES(LEFTSIDE.TYPTR,GATTR.TYPTR) OR
LEFTSIDE←REAL AND (GATTR.TYPTR=INTPTR)
THEN
IF INITGLOBALS
THEN
IF GATTR.KIND = CST
THEN STOREGLOBALS
ELSE ERROR(504)
ELSE
IF (GATTR.KIND=CST) AND (GATTR.CVAL.IVAL=0) AND
(LEFTSIDE.PACKFG<>PACKK)
THEN WITH LEFTSIDE DO
BEGIN
FETCH←BASIS(LEFTSIDE);
WITH TYPTR↑ DO
IF FORM = SUBRANGE
THEN
IF LEFTSIDE←REAL
THEN
BEGIN
IF (VMIN.VALP↑.RVAL > 0) OR (VMAX.VALP↑.RVAL < 0)
THEN ERROR(367)
END
ELSE
IF (VMIN.IVAL > 0) OR (VMAX.IVAL < 0)
THEN ERROR(367) ;
CASE PACKFG OF
NOTPACK:
LINSTR := 402B(*SETZM*);
HWORDL:
LINSTR := 553B(*HRRZS*);
HWORDR:
LINSTR := 513B(*HLLZS*)
END (*CASE*);
MACRO(VRELBYTE,LINSTR,0,INDBIT,INDEXR,DPLMT)
END
ELSE
IF AOS >= AOSINSTR
THEN
BEGIN
IC := OLDIC; CIX := OLDIX;
IF AOS=AOSINSTR
THEN GENERATE←CODE(350B(*AOS*),0,LEFTSIDE)
ELSE GENERATE←CODE(370B(*SOS*),0,LEFTSIDE)
END
ELSE
CASE LEFTSIDE.TYPTR↑.FORM OF
SCALAR,
POINTER,
POWER:
BEGIN
LOAD(GATTR);
IF (GATTR.TYPTR=INTPTR) AND LEFTSIDE←REAL
THEN MAKEREAL(GATTR);
STORE(GATTR.REG,LEFTSIDE)
END;
SUBRANGE:
BEGIN
CMIN := LEFTSIDE.TYPTR↑.VMIN;
CMAX := LEFTSIDE.TYPTR↑.VMAX;
IF LEFTSIDE←REAL
THEN
IF GATTR.TYPTR=INTPTR
THEN MAKEREAL(GATTR);
IF GATTR.KIND = CST
THEN WITH GATTR DO
BEGIN
IF LEFTSIDE←REAL
THEN
BEGIN
IF (CVAL.VALP↑.RVAL < CMIN.VALP↑.RVAL)
OR (CVAL.VALP↑.RVAL > CMAX.VALP↑.RVAL)
THEN ERROR(367)
END (*LEFTSIDE←REAL*)
ELSE
IF (CVAL.IVAL < CMIN.IVAL) OR (CVAL.IVAL > CMAX.IVAL)
THEN ERROR (367);
LOAD(GATTR)
END (*=CST*)
ELSE
IF RUNTIME←CHECK AND ((GATTR.KIND<>VARBL) OR (GATTR.SUBKIND <> LEFTSIDE.TYPTR))
THEN
BEGIN
LOAD(GATTR);
WITH SLATTR DO
BEGIN
TYPTR:= GATTR.TYPTR;
KIND := CST;
CVAL := CMAX
END;
GENERATE←CODE(317B(*CAMG*),REGC,SLATTR);
SLATTR.KIND:=CST;
SLATTR.CVAL:=CMIN;
GENERATE←CODE(315B(*CAMGE*),REGC,SLATTR);
SUPPORT(ERRORINASSIGNMENT)
END (*RUNTIMECHECK*)
ELSE LOAD(GATTR);
STORE(GATTR.REG,LEFTSIDE)
END;
ARRAYS,
RECORDS:
IF GATTR.TYPTR↑.SIZE = 1
THEN
BEGIN
LOAD(GATTR) ; STORE(GATTR.REG,LEFTSIDE)
END
ELSE WITH LEFTSIDE DO
BEGIN
LOAD←ADDRESS ;
CODE←ARRAY↑.INSTRUCTION[CIX].INSTR := 515B(*HRLZI*) ;
FETCH←BASIS(LEFTSIDE);
MACRO(VRELBYTE,541B(*HRRI*),REGC,INDBIT,INDEXR,DPLMT);
IF INDBIT=0
THEN MACRO5(VRELBYTE,251B(*BLT *),REGC,INDEXR,DPLMT+TYPTR↑.SIZE-1)
ELSE
BEGIN
INCREMENT←REGC ;
MACRO3(200B(*MOVE*),REGC,REGC-1);
MACRO4(251B(*BLT *),REGC,REGC-1,TYPTR↑.SIZE-1)
END
END;
FILES:
ERROR(361)
END (*CASE*)
ELSE ERROR(260);
AOS := B0
END (*SY = BECOMES*)
ELSE ERROR(159)
END (*ASSIGNMENT*) ;
PROCEDURE GOTOSTATEMENT;
VAR
LCP: CTP; LSCOPE: LEVRANGE;
BEGIN
IF SY = INTCONST
THEN
BEGIN
SEARCHID([LABELS],LCP);
IF LCP <> NIL
THEN
WITH LCP↑ DO
BEGIN
LSCOPE := LEVEL - SCOPE;
MACRO3R(254B(*JRST*),0,GOTO←CHAIN);
GOTO←CHAIN := IC-1; CODE←REFERENCE↑[CIX] := GOTOREF;
IF LSCOPE > 0
THEN
IF (SCOPE = 1) AND EXTERNAL
THEN ERROR(508)
ELSE EXIT←JUMP := TRUE
END;
INSYMBOL
END
ELSE ERROR(255)
END (*GOTOSTATEMENT*) ;
PROCEDURE COMPOUNDSTATEMENT;
BEGIN
LOOP
REPEAT
STATEMENT(FSYS,STATENDS)
UNTIL NOT (SY IN STATBEGSYS)
EXIT IF SY <> SEMICOLON;
INSYMBOL
END;
IF SY = ENDSY
THEN INSYMBOL
ELSE ERROR(163)
END (*COMPOUNDSTATEMENET*) ;
PROCEDURE IFSTATEMENT;
VAR
LCIX1,LCIX2: CODERANGE;
BEGIN
EXPRESSION(FSYS + [THENSY],FALSEJMP);
LCIX1 := CIX;
IF SY = THENSY
THEN INSYMBOL
ELSE ERROR(164);
STATEMENT(FSYS + [ELSESY],STATENDS + [ELSESY]);
IF SY = ELSESY
THEN
BEGIN
MACRO3(254B(*JRST*),0,0); LCIX2 := CIX;
INSERT←ADDRESS(RIGHT,LCIX1,IC);
INSYMBOL; STATEMENT(FSYS,STATENDS);
INSERT←ADDRESS(RIGHT,LCIX2,IC)
END
ELSE INSERT←ADDRESS(RIGHT,LCIX1,IC)
END (*IFSTATEMENT*) ;
PROCEDURE CASESTATEMENT;
LABEL
888,999;
TYPE
CIP = ↑CASEINFO;
CASEINFO = PACKED
RECORD
NEXT: CIP;
CSSTART: ADDRRANGE;
CSEND: CODERANGE;
CSLAB: INTEGER
END;
VAR
LSP, LSP1: STP;
FSTPTR, LPT1, LPT2, LPT3, OTHERSPTR: CIP;
LVAL: VALU;
LIC, LADDR, JUMPADDR, LMIN, LMAX: ADDRRANGE;
LCIX: CODERANGE;
PROCEDURE INSERTBOUND(FCIX: CODERANGE; FIC: ADDRRANGE; BOUND: INTEGER);
VAR
LCIX1:CODERANGE;
LIC1: ADDRRANGE;
LATTR:ATTR;
BEGIN
IF BOUND >= 0
THEN INSERT←ADDRESS(NO,FCIX,BOUND)
ELSE
BEGIN
LCIX1:=CIX; LIC1 := IC;
CIX:=FCIX; IC := FIC;
WITH LATTR DO
BEGIN
KIND:=CST;
CVAL.IVAL:=BOUND;
TYPTR:=NIL
END;
DEPOSIT←CONSTANT(INT,LATTR);
CIX:=LCIX1; IC:= LIC1;
WITH CODE←ARRAY↑.INSTRUCTION[FCIX] DO
INSTR:=INSTR+10B (*CAILE-->CAMLE, CAIL-->CAML*)
END
END (*INSERTBOUND*);
BEGIN
OTHERSPTR:=NIL;
EXPRESSION(FSYS + [OFSY,COMMA,COLON],ONREGC);
LOAD(GATTR);
MACRO2(301B(*CAIL*),REGC); (*<<<---- LMIN IS INSERTED HERE*)
MACRO2(303B(*CAILE*),REGC); (*<<<---- LMAX IS INSERTED HERE*)
MACRO2(254B(*JRST*),0); (*<<<---- START OF "OTHERS" IS INSERTED HERE*)
MACRO(NO,254B(*JRST*),0,1,REGC,0);(*<<<---- START OF JUMP TABLE IS INSERTED HERE*)
LCIX := CIX; LIC := IC;
LSP := GATTR.TYPTR;
IF LSP <> NIL
THEN
IF (LSP↑.FORM <> SCALAR) OR (LSP = REALPTR)
THEN
BEGIN
ERROR(315); LSP := NIL
END;
IF SY = OFSY
THEN INSYMBOL
ELSE ERROR(160);
FSTPTR := NIL; LPT3 := NIL;
LOOP
LOOP
CONSTANT(FSYS + [COMMA,COLON],LSP1,LVAL);
IF LSP <> NIL
THEN
IF COMPTYPES(LSP,LSP1)
THEN
BEGIN
LPT1 := FSTPTR; LPT2 := NIL;
IF ABS(LVAL.IVAL) > HWCSTMAX
THEN ERROR(316);
WHILE LPT1 <> NIL DO
WITH LPT1↑ DO
BEGIN
IF CSLAB <= LVAL.IVAL
THEN
BEGIN
IF CSLAB = LVAL.IVAL
THEN ERROR(261);
GOTO 888
END;
LPT2 := LPT1; LPT1 := NEXT
END;
888:
NEW(LPT3);
WITH LPT3↑ DO
BEGIN
NEXT := LPT1; CSLAB := LVAL.IVAL;
CSSTART := IC; CSEND := 0
END;
IF LPT2 = NIL
THEN FSTPTR := LPT3
ELSE LPT2↑.NEXT := LPT3
END
ELSE ERROR(505)
EXIT IF SY <> COMMA;
INSYMBOL
END;
IF SY = COLON
THEN INSYMBOL
ELSE ERROR(151);
REPEAT
STATEMENT(FSYS,STATENDS)
UNTIL NOT (SY IN STATBEGSYS);
IF LPT3 <> NIL
THEN
BEGIN
MACRO2(254B(*JRST*),0); LPT3↑.CSEND := CIX
END
EXIT IF SY <> SEMICOLON;
INSYMBOL;
IF SY=OTHERSSY
THEN
BEGIN
INSYMBOL;
IF SY=COLON
THEN INSYMBOL
ELSE ERROR(151);
NEW(OTHERSPTR);
WITH OTHERSPTR↑ DO
BEGIN
CSSTART:=IC;
REPEAT
STATEMENT(FSYS,STATENDS)
UNTIL NOT(SY IN STATBEGSYS);
MACRO2(254B(*JRST*),0);
CSEND:=CIX;
IF SY = SEMICOLON
THEN INSYMBOL;
GOTO 999
END
END
ELSE
IF SY = ENDSY
THEN GOTO 999
END;
999:
IF FSTPTR <> NIL
THEN
BEGIN
LMAX := FSTPTR↑.CSLAB;
(*REVERSE POINTERS*)
LPT1 := FSTPTR; FSTPTR := NIL;
REPEAT
LPT2 := LPT1↑.NEXT; LPT1↑.NEXT := FSTPTR;
FSTPTR := LPT1; LPT1 := LPT2
UNTIL LPT1 = NIL;
LMIN := FSTPTR↑.CSLAB;
INSERTBOUND(LCIX-2,LIC-2,LMAX);
INSERTBOUND(LCIX-3,LIC-3,LMIN);
INSERT←ADDRESS(RIGHT,LCIX,IC-LMIN);
IF (LMAX - LMIN) < (CODE←SIZE - CIX)
THEN
BEGIN
LADDR := IC + LMAX - LMIN + 1;
IF OTHERSPTR = NIL
THEN JUMPADDR := LADDR
ELSE
BEGIN
INSERT←ADDRESS(RIGHT,OTHERSPTR↑.CSEND,LADDR);
JUMPADDR:=OTHERSPTR↑.CSSTART
END;
INSERT←ADDRESS(RIGHT,LCIX-1,JUMPADDR);
REPEAT
WITH FSTPTR↑ DO
BEGIN
WHILE CSLAB > LMIN DO
BEGIN
GENERATE←WORD(RIGHT,0,JUMPADDR); LMIN := LMIN + 1
END;
GENERATE←WORD(RIGHT,0,CSSTART);
IF CSEND <> 0
THEN INSERT←ADDRESS(RIGHT,CSEND,LADDR);
FSTPTR := NEXT; LMIN := LMIN + 1
END
UNTIL FSTPTR = NIL
END
ELSE
BEGIN
IF NOT OVERRUN
THEN
BEGIN
OVERRUN := TRUE;
IF FPROCP = NIL
THEN ERROR←WITH←TEXT(356,'MAIN ')
ELSE ERROR←WITH←TEXT(356,FPROCP↑.NAME)
END;
CIX := 0
END
END;
IF SY = ENDSY
THEN INSYMBOL
ELSE ERROR(163)
END (*CASESTATEMENT*) ;
PROCEDURE REPEATSTATEMENT;
VAR
LADDR: ADDRRANGE;
BEGIN
LADDR := IC;
LOOP
REPEAT
STATEMENT(FSYS + [UNTILSY],STATENDS + [UNTILSY])
UNTIL NOT (SY IN STATBEGSYS)
EXIT IF SY <> SEMICOLON;
INSYMBOL
END;
IF SY = UNTILSY
THEN
BEGIN
INSYMBOL; EXPRESSION(FSYS,FALSEJMP); INSERT←ADDRESS(RIGHT,CIX,LADDR)
END
ELSE ERROR(202)
END (*REPEATSTATEMENT*) ;
PROCEDURE WHILESTATEMENT;
VAR
LADDR: ADDRRANGE;
LCIX: CODERANGE;
BEGIN
LADDR := IC;
EXPRESSION(FSYS + [DOSY],FALSEJMP);
LCIX := CIX;
IF SY = DOSY
THEN INSYMBOL
ELSE ERROR(161);
STATEMENT(FSYS,STATENDS);
MACRO3R(254B(*JRST*),0,LADDR);
INSERT←ADDRESS(RIGHT,LCIX,IC)
END (*WHILESTATEMENT*) ;
PROCEDURE FORSTATEMENT;
VAR
LATTR: ATTR;
LSP: STP;
LSY: SYMBOL;
LCIX: CODERANGE;
LADDR,LDPLMT: ADDRRANGE;
LINSTR: INSTRANGE;
LREGC,LINDREG: ACRANGE;
LINDBIT: IBRANGE;
LRELBYTE: RELBYTE;
ADDTOLC: ADDRRANGE;
BEGIN
IF SY = IDENT
THEN
BEGIN
SEARCHID([VARS],LCP);
WITH LCP↑, LATTR DO
BEGIN
TYPTR := IDTYPE; KIND := VARBL;
IF VKIND = ACTUAL
THEN
BEGIN
VLEVEL := VLEV;
IF VLEV > 1
THEN VRELBYTE := NO
ELSE VRELBYTE := RIGHT;
DPLMT := VADDR; INDEXR :=0; PACKFG := NOTPACK;
INDBIT:=0
END
ELSE
BEGIN
ERROR(364); TYPTR := NIL
END
END;
IF LATTR.TYPTR <> NIL
THEN
IF COMPTYPES(REALPTR,LATTR.TYPTR) OR (LATTR.TYPTR↑.FORM > SUBRANGE)
THEN
BEGIN
ERROR(365); LATTR.TYPTR := NIL
END;
INSYMBOL
END
ELSE
BEGIN
ERRANDSKIP(209,FSYS + [BECOMES,TOSY,DOWNTOSY,DOSY]);
LATTR.TYPTR := NIL
END;
IF SY = BECOMES
THEN
BEGIN
INSYMBOL; EXPRESSION(FSYS + [TOSY,DOWNTOSY,DOSY],ONREGC);
IF GATTR.TYPTR <> NIL
THEN
IF GATTR.TYPTR↑.FORM <> SCALAR
THEN ERROR(315)
ELSE
IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
THEN LOAD(GATTR)
ELSE ERROR(556);
LREGC := GATTR.REG
END
ELSE ERRANDSKIP(159,FSYS + [TOSY,DOWNTOSY,DOSY]);
IF SY IN [TOSY,DOWNTOSY]
THEN
BEGIN
LSY := SY; INSYMBOL; EXPRESSION(FSYS + [DOSY],ONREGC);
IF GATTR.TYPTR <> NIL
THEN
IF GATTR.TYPTR↑.FORM <> SCALAR
THEN ERROR(315)
ELSE
IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)
THEN
BEGIN
ADDTOLC := 0 ;
WITH GATTR DO
IF ((KIND = VARBL) AND
(((VLEVEL > 1) AND (VLEVEL < LEVEL)) OR
(PACKFG <> NOTPACK) OR
((INDEXR > 0) AND (INDEXR <= REGCMAX)))) OR
(KIND = EXPR)
THEN
BEGIN
LOAD(GATTR); MACRO4(202B(*MOVEM*),REGC,BASIS,LC); ADDTOLC := 1;
KIND := VARBL ; INDBIT := 0 ; INDEXR := BASIS ; VLEVEL := 1;
DPLMT := LC ; PACKFG := NOTPACK ; VRELBYTE := NO
END ;
FETCH←BASIS(LATTR);
WITH LATTR DO
BEGIN
IF (INDEXR>0) AND (INDEXR<=REGCMAX)
THEN
BEGIN
MACRO(NO,551B(*HRRZI*),INDEXR,INDBIT,INDEXR,DPLMT);
LINDBIT := 1; LDPLMT := LC+ADDTOLC; LINDREG := BASIS ;
MACRO4(202B(*MOVEM*),INDEXR,BASIS,LDPLMT);
ADDTOLC := ADDTOLC + 1
END
ELSE
BEGIN
LINDBIT := INDBIT; LINDREG := INDEXR; LDPLMT := DPLMT
END;
LRELBYTE:= VRELBYTE
END;
MACRO(LRELBYTE,202B(*MOVEM*),LREGC,LINDBIT,LINDREG,LDPLMT);
IF LSY = TOSY
THEN LINSTR := 313B(*CAMLE*)
ELSE LINSTR := 315B(*CAMGE*);
LADDR := IC;
GENERATE←CODE(LINSTR,LREGC,GATTR)
END
ELSE ERROR(556)
END
ELSE ERRANDSKIP(251,FSYS + [DOSY]);
MACRO3(254B(*JRST*),0,0); LCIX :=CIX;
IF SY = DOSY
THEN INSYMBOL
ELSE ERROR(161);
LC := LC + ADDTOLC;
IF LC > LCMAX
THEN LCMAX:=LC;
STATEMENT(FSYS,STATENDS);
LC := LC - ADDTOLC;
IF LSY = TOSY
THEN LINSTR := 350B(*AOS*)
ELSE LINSTR := 370B(*SOS*);
MACRO(LRELBYTE,LINSTR,LREGC,LINDBIT,LINDREG,LDPLMT);
MACRO3R(254B(*JRST*),0,LADDR); INSERT←ADDRESS(RIGHT,LCIX,IC)
END (*FORSTATEMENT*) ;
PROCEDURE LOOPSTATEMENT;
VAR
LADDR: ADDRRANGE;
LCIX: CODERANGE;
BEGIN
LADDR := IC;
LOOP
REPEAT
STATEMENT(FSYS + [EXITSY],STATENDS + [EXITSY])
UNTIL NOT (SY IN STATBEGSYS)
EXIT IF SY <> SEMICOLON;
INSYMBOL
END;
IF SY = EXITSY
THEN
BEGIN
INSYMBOL;
IF SY = IFSY
THEN
BEGIN
INSYMBOL; EXPRESSION(FSYS + [SEMICOLON,ENDSY],TRUEJMP)
END
ELSE ERRANDSKIP(162,FSYS + [SEMICOLON,ENDSY]);
LCIX := CIX;
LOOP
REPEAT
STATEMENT(FSYS,STATENDS)
UNTIL NOT (SY IN STATBEGSYS)
EXIT IF SY <> SEMICOLON;
INSYMBOL
END;
MACRO3R(254B(*JRST*),0,LADDR); INSERT←ADDRESS(RIGHT,LCIX,IC)
END
ELSE ERROR(165);
IF SY = ENDSY
THEN INSYMBOL
ELSE ERROR(163)
END (*LOOPSTATEMENT*) ;
PROCEDURE WITHSTATEMENT;
VAR
LCP: CTP; OLDLC: ADDRRANGE; LCNT1: DISPRANGE; OLDREGC: ACRANGE;
BEGIN
LCNT1 := 0; OLDREGC := REGCMAX; OLDLC := LC;
LOOP
IF SY = IDENT
THEN
BEGIN
SEARCHID([VARS,FIELD],LCP); INSYMBOL
END
ELSE
BEGIN
ERROR(209); LCP := UVARPTR
END;
SELECTOR(FSYS + [COMMA,DOSY],LCP);
IF GATTR.TYPTR <> NIL
THEN
IF GATTR.TYPTR↑.FORM = RECORDS
THEN
IF TOP < DISPLIMIT
THEN
BEGIN
TOP := TOP + 1; LCNT1 := LCNT1 + 1; WITHIX := WITHIX + 1;
WITH DISPLAY[TOP], GATTR DO
BEGIN
FNAME := TYPTR↑.FSTFLD;
OCCUR := CREC;
IF INDBIT = 1
THEN GET←PARAMETER←ADDRESS;
FETCH←BASIS(GATTR);
IF (INDEXR<>0) AND (INDEXR <> BASIS)
THEN
BEGIN
MACRO3(550B(*HRRZ*),REGCMAX,INDEXR);
INDEXR := REGCMAX;
REGCMAX := REGCMAX-1;
IF REGCMAX<REGC
THEN
BEGIN
ERROR(317);
REGC := REGCMAX
END
END;
CLEV := VLEVEL; CRELBYTE := VRELBYTE;
CINDR := INDEXR; CINDB:=INDBIT;
CDSPL := DPLMT;
CLC := LC;
IF (CINDR<>0) AND (CINDR<>BASIS)
THEN
BEGIN
LC := LC + 1;
IF LC>LCMAX
THEN LCMAX := LC
END
END
END
ELSE ERROR(404)
ELSE ERROR(308)
EXIT IF SY <> COMMA;
INSYMBOL
END;
IF SY = DOSY
THEN INSYMBOL
ELSE ERROR(161);
STATEMENT(FSYS,STATENDS);
REGCMAX:=OLDREGC;
TOP := TOP - LCNT1; LC := OLDLC; WITHIX := WITHIX - LCNT1
END (*WITHSTATEMENT*) ;
BEGIN
(*STATEMENT*)
IF SY = INTCONST
THEN (*LABEL*)
BEGIN
SEARCHID([LABELS],LCP);
IF LCP <> NIL
THEN
WITH LCP↑ DO
BEGIN
IF LABEL←ADDRESS = 0
THEN
BEGIN
IF EXIT←JUMP
THEN MACRO3R(324B(*JUMPA*),REG0,IC+3);
LABEL←ADDRESS := IC;
IF EXIT←JUMP
THEN
BEGIN
MACRO3R(200B(*MOVE*),BASIS,JUMP←TABLE[JUMP←INDEX]); CODE←REFERENCE↑[CIX] := SAVEREF;
MACRO3R(200B(*MOVE*),TOPP,JUMP←TABLE[JUMP←INDEX] + 1); CODE←REFERENCE↑[CIX] := SAVEREF;
JUMP←TABLE[JUMP←INDEX] := LABEL←ADDRESS
END
END
ELSE ERROR(211);
IF SCOPE <> LEVEL
THEN ERROR(352)
END;
INSYMBOL;
IF SY = COLON
THEN INSYMBOL
ELSE ERROR(151)
END;
IF NOT (SY IN FSYS + [IDENT])
THEN ERRANDSKIP(166,FSYS);
IF SY IN STATBEGSYS + [IDENT]
THEN
IF INITGLOBALS
THEN
IF SY <> IDENT
THEN ERROR(462)
ELSE
BEGIN
SEARCHID([VARS,FIELD,FUNC,PROC],LCP); INSYMBOL;
IF LCP↑.KLASS = PROC
THEN ERROR(462)
ELSE ASSIGNMENT(LCP)
END
ELSE (*...NOT INITGLOBALS*)
BEGIN
IF DEBUG←SWITCH
THEN PUT←LINENUMBER;
REGC := REGIN;
CASE SY OF
IDENT:
BEGIN
SEARCHID([VARS,FIELD,FUNC,PROC],LCP); INSYMBOL;
WITH LCP↑ DO
IF (KLASS = VARS) AND (VLEV = 0) AND (SY = ARROW) AND
(IDTYPE↑.FORM = FILES) AND (NAME = 'TTY ')
THEN
BEGIN
ID := 'TTYOUTPUT '; SEARCHID([VARS],LCP)
END;
IF LCP↑.KLASS = PROC
THEN CALL(FSYS,LCP)
ELSE ASSIGNMENT(LCP)
END;
BEGINSY:
BEGIN
INSYMBOL; COMPOUNDSTATEMENT
END;
GOTOSY:
BEGIN
INSYMBOL; GOTOSTATEMENT
END;
IFSY:
BEGIN
INSYMBOL; IFSTATEMENT
END;
CASESY:
BEGIN
INSYMBOL; CASESTATEMENT
END;
WHILESY:
BEGIN
INSYMBOL; WHILESTATEMENT
END;
REPEATSY:
BEGIN
INSYMBOL; REPEATSTATEMENT
END;
LOOPSY:
BEGIN
INSYMBOL; LOOPSTATEMENT
END;
FORSY:
BEGIN
INSYMBOL; FORSTATEMENT
END;
WITHSY:
BEGIN
INSYMBOL; WITHSTATEMENT
END
END (*CASE*) ;
(* RE-INITIALIZE REGISTER COUNTER TO AVOID OVERFLOW DURING SUBSEQUENT
EXPRESSION EVALUATIONS IN REPEATSTATEMENT OR LOOPSTATEMENT *)
REGC := REGIN
END (*..NOT INITGLOBALS*);
SKIPIFERR(STATENDS,506,FSYS)
END (*STATEMENT*) ;
BEGIN
(*BODY*)
REGCMAX:=WITHIN; WITHIX := -1; FIRSTKONST := NIL;
REG2←SAVED := FALSE;
IF NOT ENTRY←DONE
THEN
BEGIN
ENTRY←DONE:= TRUE;
WRITE←MACHINE←CODE(WRITE←ENTRY);
WRITE←MACHINE←CODE(WRITE←NAME);
WRITE←MACHINE←CODE(WRITE←HISEG)
END;
CIX := -1 ;
IF INITGLOBALS
THEN
BEGIN
CGLOBPTR := NIL ;
LOOP
IF SY <> ENDSY
THEN STATEMENT([SEMICOLON,ENDSY],[SEMICOLON,ENDSY])
EXIT IF SY <> SEMICOLON ;
INSYMBOL
END ;
IF SY = ENDSY
THEN INSYMBOL
ELSE ERROR(163) ;
WRITE←MACHINE←CODE(WRITE←GLOBALS)
END
ELSE
BEGIN
ENTERBODY;
IF FPROCP <> NIL
THEN FPROCP↑.PFADDR:= PFSTART
ELSE LC:= 1;
LCMAX:=LC;
LOOP
REPEAT
STATEMENT(FSYS + [SEMICOLON,ENDSY],[SEMICOLON,ENDSY])
UNTIL NOT (SY IN STATBEGSYS)
EXIT IF SY <> SEMICOLON;
INSYMBOL
END;
IF SY = ENDSY
THEN INSYMBOL
ELSE ERROR(163);
LEAVEBODY;
INSERT←ADDRESS(NO,STACKSIZE1,LCMAX);
INSERT←ADDRESS(NO,STACKSIZE2,LCMAX);
WRITE←MACHINE←CODE(WRITE←CODE);
IF DEBUG
THEN WRITE←MACHINE←CODE(WRITE←DEBUG);
WRITE←MACHINE←CODE(WRITE←INTERNALS);
IF LEVEL = 1
THEN
BEGIN
WRITE←MACHINE←CODE(WRITE←FILEBLOCKS);
WRITE←MACHINE←CODE(WRITE←SYMBOLS);
WRITE←MACHINE←CODE(WRITE←LIBRARY);
WRITE←MACHINE←CODE(WRITE←START);
WRITE←MACHINE←CODE(WRITE←END)
END
END
END (*BODY*) ;
BEGIN
(*BLOCK*)
NEW(HEAPMARK);
DP := TRUE; TESTPACKED := FALSE; FORWARD←PROCEDURES := NIL; CURRENT←JUMP := 0;
REPEAT
WHILE SY IN BLOCKBEGSYS - [BEGINSY] DO
BEGIN
IF SY = LABELSY
THEN
BEGIN
INSYMBOL; LABELDECLARATION
END;
IF SY = CONSTSY
THEN
BEGIN
INSYMBOL; CONSTANTDECLARATION
END;
IF SY = TYPESY
THEN
BEGIN
INSYMBOL; TYPEDECLARATION
END;
LCPAR := LC;
IF SY = VARSY
THEN
BEGIN
INSYMBOL; VARIABLEDECLARATION
END;
IF (LEVEL > 1) AND (SY = INITPROCSY)
THEN ERRANDSKIP(363,BLOCKBEGSYS - [INITPROCSY]);
IF LEVEL = 1
THEN
BEGIN
WHILE SY = INITPROCSY DO
BEGIN
INSYMBOL ;
IF SY <> SEMICOLON
THEN ERRANDSKIP(156,[BEGINSY])
ELSE INSYMBOL ;
IF SY = BEGINSY
THEN
BEGIN
NEW(GLOBMARK); INITGLOBALS := TRUE ;
INSYMBOL ; BODY(FSYS + [SEMICOLON,ENDSY]) ;
IF SY = SEMICOLON
THEN INSYMBOL
ELSE ERROR(166) ;
INITGLOBALS := FALSE; DISPOSE(GLOBMARK)
END
ELSE ERROR(201)
END ;
LCMAIN := LC; TESTPACKED := FALSE
END;
WHILE SY IN [PROCEDURESY,FUNCTIONSY] DO
BEGIN
LSY := SY; INSYMBOL; PROCEDUREDECLARATION(LSY=PROCEDURESY)
END;
WHILE FORWARD←PROCEDURES <> NIL DO
WITH FORWARD←PROCEDURES↑ DO
BEGIN
IF FORWDECL
THEN ERROR←WITH←TEXT(465,NAME);
FORWARD←PROCEDURES := TESTFWDPTR
END;
SKIPIFERR([BEGINSY],201,FSYS)
END;
DP := FALSE;
IF SY = BEGINSY
THEN INSYMBOL
ELSE ERROR (201);
BODY(FSYS + [CASESY]);
SKIPIFERR(LEAVEBLOCKSYS,166,FSYS)
UNTIL SY IN LEAVEBLOCKSYS;
DISPOSE(HEAPMARK)
END (*BLOCK*) ;
BEGIN (* COMPILE *)
WRITELN(TTY); WRITE(TTY, HEADER:6, ': ',OBJECT←FILE:6); BREAK(TTY);
ERROR←IN←HEADING := TRUE;
GETNEXTLINE; CH := ' '; INSYMBOL; RESET←POSSIBLE := FALSE;
NEW( CODE←ARRAY, PDP10CODE: CODE←SIZE );
NEW( CODE←REFERENCE: CODE←SIZE );
NEW( CODE←RELOCATION: CODE←SIZE );
(*******************************************************************************************
*
* <PROGRAM LIBRARY> ::= [<OPTION SEQUENCE>] [<PROGRAM>]*
* <PROGRAM> ::= <PROGRAM HEADING><BLOCK>.
* <PROGRAM HEADING> ::= PROGRAM <PROGRAMNAME>
* [,<ENTRY>]*
* [(<FILE IDENTIFIER>[,<FILE IDENTIFIER>]* )];
* <OPTION SEQUENCE> ::= ( *$ <OPTION>[,<OPTION>]* <ANY COMMENT> * )
* <OPTION> ::= <LETTER><SIGN>
* <LETTER> ::= [D, E, L, P, T, U]
* <SIGN> ::= [+, -]
*
* <PROGRAMNAME> ::= <IDENTIFIER>
* <FILE IDENTIFIER> ::= <IDENTIFIER>
* <ENTRY> ::= <IDENTIFIER>
*
************************************ COMPILER OPTIONS ************************************
*
* DEC-10 PASCAL FUNCTION DEFAULT
*
* [NO]LIST(+) - GENERATE LIST FILE OFF
* [NO]CODE L+/L- LIST OBJECT CODE OFF
* [NO]CHECK T+/T- PERFORM RUNTIME CHECKS ON
* [NO]DEBUG D+/D-, P+/P-($) GENERATE DEBUG INFORMATION
* INCLUDING POST-MORTEM DUMP OFF
* [NO]COMPILE(+) - COMPILE THE FILE ON
* [NO]EXTERN E+/E-(@) ALL LEVEL-1 PROCEDURES
* AND FUNCTIONS MAY BE DE-
* CLARED AS "EXTERN" BY OTHER
* PROGRAMS. THESE ENTRIES MUST
* BE DEFINED IN THE PROGRAM
* HEADING ADDITIONALLY OFF
* [NO]CARD U+/U-(@) ONLY 72 CHARS OF THE SOURCE
* LINE ARE ACCEPTED (CARD FORMAT) OFF
* FORTIO I+/I- ENABLE FORTRAN-I/O IN EXTERNAL
* FORTRAN PROGRAMS OFF
* CODESIZE:N SN MAXIMUM NUMBER OF
* CODE WORDS FOR A BODY CIXMAX
* RUNCORE:N RN SIZE OF LOW-SEGMENT LOW-BREAK
* FILE:N FN THIS OPTION IS
* NECESSARY IF FILES ARE
* DECLARED IN EXTERNAL PROGRAMS.
* N IS THE NUMBER OF FILES
* ALREADY DECLARED IN THE MAIN
* (AND/OR OTHER EXTERNAL)
* PROGRAM(S) PLUS 1 0
* [NO]CREF(+) - GENERATE CROSS REFERENCE LIST OFF
* [NO]LINK - CALL LINK-10 AFTER COMPILATION OFF
* [NO]EXECUTE - LOAD AND RUN COMPILED PROGRAM OFF
* REGISTER:N XN HIGHEST REGISTER USED
* TO PASS PARAMETERS STDPARREGCMAX
*
* SWITCHES MARKED WITH A (+) ARE ALSO PART OF THE DECSYSTEM-10 CONCISE COMMAND
* LANGUAGE. THE OTHERS MUST BE ENCLOSED IN "()" IF SPECIFIED
* IN A COMPILE-, LOAD-, EXECUTE- OR DEBUG-COMMAND-STRING,
* E.G.: COMPILE PASRL1=PASCAL.PAS(DEBUG/EXTERN)/LIST/COMPILE
*
* SWITCHES MARKED WITH ($) OR (@) MUST BE SPECIFIED FOR THE FIRST TIME BEFORE THE
* <PROGRAM HEADING>. THOSE WITH (@) CANNOT BE RE-DEFINED AGAIN INSIDE A <PROGRAM>,
* THOSE WITH ($) MIGHT BE RE-DEFINED INSIDE A <PROGRAM> OR
* <PROGRAM LIBRARY>. ALL OTHER SWITCHES CAN BE DEFINED AND
* RE-DEFINED ANYWHERE INSIDE A PROGRAM.
*
*******************************************************************************************)
IF EXTERNAL
THEN
BEGIN
LC := LOW←START; LCMAIN := LC;
WHILE SFILEPTR <> NIL DO
WITH SFILEPTR↑, FILEIDENT↑ DO
BEGIN
VADDR := 0; SFILEPTR := NEXTFTP
END;
SFILEPTR := FILEPTR
END;
IF SY = PROGRAMSY
THEN
BEGIN
INSYMBOL;
IF SY = IDENT
THEN
BEGIN
PROGRAMNAME := ID; ESCAPE := FALSE;
WHILE (ENTRIES < ENTRYMAX) AND (SY = IDENT) AND NOT ESCAPE DO
BEGIN
ENTRIES := ENTRIES + 1;
ENTRY[ ENTRIES ] := ID;
INSYMBOL;
IF SY = COMMA
THEN
BEGIN
INSYMBOL;
IF SY <> IDENT
THEN
BEGIN
ESCAPE := TRUE; ERROR(209)
END
END
ELSE
IF NOT (SY IN [SEMICOLON,LPARENT])
THEN
BEGIN
ESCAPE := TRUE; ERROR(156)
END
END;
IF SY = LPARENT
THEN
BEGIN
REPEAT
INSYMBOL;
IF SY = IDENT
THEN
BEGIN
NEW(LPARMPTR);
IF PARMPTR = NIL
THEN PARMPTR := LPARMPTR;
WITH LPARMPTR↑ DO
BEGIN
FILEID := ID; FILEIDPTR := NIL;
FOR I := 1 TO 2 DO
IF FILEID = NA[STDFILE,I]
THEN FILEIDPTR := STDFILEPTR[I];
NEXTPTP := NIL;
IF BACKWPARMPTR <> NIL
THEN BACKWPARMPTR↑.NEXTPTP := LPARMPTR;
BACKWPARMPTR := LPARMPTR; INSYMBOL;
IF (SY IN [MULOP,ADDOP]) AND (OP IN [MUL,PLUS])
THEN
BEGIN
IF OP = PLUS
THEN ERROR(169);
INPUTFILE := TRUE; INSYMBOL
END
END
END
ELSE (*SY <> IDENT*)
ERROR(209)
UNTIL SY <> COMMA;
IF SY <> RPARENT
THEN ERRANDSKIP(152,BLOCKBEGSYS)
ELSE
BEGIN
INSYMBOL;
SKIPIFERR([SEMICOLON],156,BLOCKBEGSYS)
END
END
ELSE (*SY <> LPARENT*)
SKIPIFERR([SEMICOLON],156,BLOCKBEGSYS)
END
ELSE (*SY <> IDENT*)
ERRANDSKIP(209,BLOCKBEGSYS)
END
ELSE (*SY <> PROGRAMSY*)
ERRANDSKIP(318,BLOCKBEGSYS);
IF SY = SEMICOLON
THEN INSYMBOL;
IF NOT ERROR←FLAG
THEN
BEGIN
WRITE(TTY, ' [', PROGRAMNAME);
IF (ENTRIES > 1) AND EXTERNAL
THEN
BEGIN
WRITE(TTY,': '); I := 2;
LOOP
WRITE(TTY,ENTRY[I])
EXIT IF I >= ENTRIES;
I := I + 1;
WRITE(TTY,', ')
END
END;
WRITELN(TTY, ']');
BREAK(TTY)
END;
BLOCK(NIL,BLOCKBEGSYS + STATBEGSYS-[CASESY],[PERIOD,COLON]);
ERROR←EXIT := TRUE; ENDOFLINE;
111:
IF LPTFILE
THEN
BEGIN
WRITELN(LIST);
WRITELN(LIST,ERRORCOUNT:4,' ERROR(S) DETECTED');
WRITELN(LIST)
END;
WRITELN(TTY);
WRITELN(TTY,ERRORCOUNT:4,' ERROR(S) DETECTED');
WRITELN(TTY);
IF NOT ERROR←FLAG
THEN
BEGIN
CORE[1] := HIGHEST←CODE-HIGH←START; CORE[2] := CORE[1] MOD 1024;
CORE[1] := CORE[1] DIV 1024;
IF LPTFILE
THEN WRITELN(LIST,'HIGHSEG: ',CORE[1]:3,'K + ',CORE[2]:4,' WORD(S)');
WRITELN(TTY,'HIGHSEG: ',CORE[1]:3,'K + ',CORE[2]:4,' WORD(S)');
CORE[1] := LCMAIN DIV 1024; CORE[2] := LCMAIN MOD 1024;
IF LPTFILE
THEN
BEGIN
WRITELN(LIST,'LOWSEG : ',CORE[1]:3,'K + ',CORE[2]:4,' WORD(S)'); WRITELN(LIST)
END;
WRITELN(TTY,'LOWSEG : ',CORE[1]:3,'K + ',CORE[2]:4,' WORD(S)'); WRITELN(TTY);
END;
RTIME[0] := CLOCK-RTIME[0];
RTIME[1] := RTIME[0] DIV 60000;
RTIME[2] := (RTIME[0] MOD 60000) DIV 1000;
RTIME[3] := (RTIME[0] MOD 60000) MOD 1000;
IF LPTFILE
THEN WRITELN(LIST,'RUNTIME: ',RTIME[1]:3,':',RTIME[2]:2,'.',RTIME[3]:3) ;
WRITELN(TTY,'RUNTIME: ',RTIME[1]:3,':',RTIME[2]:2,'.',RTIME[3]:3,BEL);
BREAK(TTY);
DISPOSE( CODE←ARRAY, PDP10CODE: CODE←SIZE )
END (* COMPILE *);
PROCEDURE ENTERSTDTYPES;
PROCEDURE ENTERSTDSTRING(VAR STRINGPTR: STP; LOWBND, HIGHBND: INTEGER);
VAR
LBTP: BTP; LSP: STP;
BEGIN
NEW(LSP,SUBRANGE);
WITH LSP↑ DO
BEGIN
RANGETYPE := INTPTR; VMIN.IVAL := LOWBND; VMAX.IVAL := HIGHBND;
SELFSTP := NIL; SIZE := 1; BITSIZE := BITMAX
END;
NEW(STRINGPTR,ARRAYS);
WITH STRINGPTR↑ DO
BEGIN
ARRAYPF := TRUE; ARRAYBPADDR := 0; SELFSTP := NIL;
AELTYPE := ASCIIPTR; INXTYPE := LSP; SIZE := (HIGHBND-LOWBND+5) DIV 5;
BITSIZE := BITMAX
END;
NEW(LBTP);
WITH LBTP↑ DO
BEGIN
LAST := LASTBTP; ARRAYSP := STRINGPTR;
BITSIZE := 7; LASTBTP := LBTP
END;
WITH ARRAYBPS[7], ABYTE DO
BEGIN
SBITS := 7; PBITS := BITMAX; DUMMYBIT := 0;
IBIT := 0; IREG := REG1; RELADDR := 0;
BYTEMAX := 6; STATE := REQUESTED
END
END;
BEGIN
(*STANDARD TYPES*)
(****************)
NEW(INTPTR,SCALAR,STANDARD); (*INTEGER*)
WITH INTPTR↑ DO
BEGIN
SIZE := 1;BITSIZE := BITMAX; SELFSTP := NIL
END;
NEW(REALPTR,SCALAR,STANDARD); (*REAL*)
WITH REALPTR↑ DO
BEGIN
SIZE := 1;BITSIZE := BITMAX; SELFSTP := NIL
END;
NEW(ASCIIPTR,SCALAR,STANDARD); (*ASCII*)
WITH ASCIIPTR↑ DO
BEGIN
SIZE := 1;BITSIZE := 7; SELFSTP := NIL
END;
NEW(BOOLPTR,SCALAR,DECLARED); (*BOOLEAN*)
WITH BOOLPTR↑ DO
BEGIN
SIZE := 1;BITSIZE := 1; SELFSTP := NIL
END;
NEW(NILPTR,POINTER); (*NIL*)
WITH NILPTR↑ DO
BEGIN
ELTYPE := NIL; SIZE := 1; BITSIZE := 18; SELFSTP := NIL
END;
NEW(ANYFILEPTR,FILES); (*"ANY FILE"*)
WITH ANYFILEPTR↑ DO
BEGIN
FILTYPE := NIL; SIZE := 0; BITSIZE := 0; SELFSTP := NIL
END;
NEW(CHARPTR,SUBRANGE); (*CHAR*)
WITH CHARPTR↑ DO
BEGIN
SIZE := 1; BITSIZE := 7; SELFSTP := NIL;
RANGETYPE := ASCIIPTR; VMIN.IVAL := ORD(' ');
VMAX.IVAL := ORD('←')
END;
NEW(TEXTPTR,FILES); (*TEXT*)
WITH TEXTPTR↑ DO
BEGIN
FILTYPE := CHARPTR; SIZE := 1+SIZEOFFILEBLOCK; BITSIZE := BITMAX;
FILE←MODE := ASCII←MODE; FILEPF := TRUE; SELFSTP := NIL;
FILE←FORM := TEXT←FILE;
END;
ENTERSTDSTRING(ALFAPTR,1,ALFALENGTH);
ENTERSTDSTRING(PACKC9PTR,1,9);
ENTERSTDSTRING(PACKC8PTR,1,8);
ENTERSTDSTRING(PACKC6PTR,1,6);
ENTERSTDSTRING(PACKC5PTR,1,5);
SLASTBTP := LASTBTP
END (*ENTERSTDTYPES*) ;
PROCEDURE ENTERSTDNAMES;
VAR
CP: CTP;
I,J: INTEGER;
LFILEPTR: FTP;
LCSP: CSP;
PROCEDURE ENTERSTDPROCFUNC(FINDEX: INTEGER; FIDCLASS: IDCLASS; FIDTYPE: STP; FNEXT: CTP);
VAR
I: INTEGER; LCP: CTP; NAMEIX: NAMEKIND;
BEGIN
IF FIDCLASS = FUNC
THEN
BEGIN
NAMEIX := DECLFUNC; NEW(LCP,FUNC,DECLARED,ACTUAL)
END
ELSE
BEGIN
NAMEIX := DECLPROC; NEW(LCP,PROC,DECLARED,ACTUAL)
END;
WITH LCP↑ DO
BEGIN
IDTYPE := FIDTYPE; NEXT := FNEXT; FORWDECL := FALSE; HIGHEST←REGISTER := STDPARREGCMAX;
PFLEV := 0; PFADDR := 0; PFCHAIN := EXTERNPFPTR; EXTERNPFPTR := LCP; EXTERNDECL := TRUE;
FOR I := 0 TO MAXLEVEL DO LINKCHAIN[I] := 0; LANGUAGE := EXTLANGUAGE[NAMEIX,FINDEX];
EXTERNALNAME := EXTNA[NAMEIX,FINDEX]; NAME := NA[NAMEIX,FINDEX];
END;
ENTERID(LCP)
END;
PROCEDURE ENTERSTDPARAMETER(FIDTYPE: STP; FIDKIND: IDKIND; FNEXT: CTP; FADDR: INTEGER);
BEGIN
NEW(CP,VARS);
WITH CP↑ DO
BEGIN
NAME := ' '; IDTYPE := FIDTYPE;
VKIND := FIDKIND; NEXT := FNEXT; VLEV := 1; VADDR := FADDR
END
END;
PROCEDURE ENTERSTDID(FIDCLASS: IDCLASS; FNAME: ALFA; FIDTYPE: STP; FNEXT: CTP; FIVAL: INTEGER);
BEGIN
NEW(CP);
WITH CP↑ DO
BEGIN
KLASS := FIDCLASS; NAME := FNAME; IDTYPE := FIDTYPE; NEXT := FNEXT;
IF FIDCLASS = KONST
THEN VALUES.IVAL := FIVAL
END;
ENTERID(CP)
END;
BEGIN
(*STANDARDNAMES:*)
(****************)
ENTERSTDID(TYPES,'INTEGER ',INTPTR,NIL,0);
ENTERSTDID(TYPES,'REAL ',REALPTR,NIL,0);
ENTERSTDID(TYPES,'CHAR ',CHARPTR,NIL,0);
ENTERSTDID(TYPES,'ASCII ',ASCIIPTR,NIL,0);
ENTERSTDID(TYPES,'BOOLEAN ',BOOLPTR,NIL,0);
ENTERSTDID(TYPES,'TEXT ',TEXTPTR,NIL,0);
ENTERSTDID(TYPES,'ALFA ',ALFAPTR,NIL,0);
ENTERSTDID(KONST,'NIL ',NILPTR,NIL,377777B);
ENTERSTDID(KONST,'ALFALENGTH',INTPTR,NIL,10);
ENTERSTDID(KONST,'MAXINT ',INTPTR,NIL,377777777777B);
ENTERSTDID(KONST,'MININT ',INTPTR,NIL,-MAXINT - 1);
NEW(LCSP,REEL); LCSP↑.INTVAL := 377777777777B;
ENTERSTDID(KONST,'MAXREAL ',REALPTR,NIL,ORD(LCSP));
NEW(LCSP,REEL); LCSP↑.INTVAL := 400000000B;
ENTERSTDID(KONST,'SMALLREAL ',REALPTR,NIL,ORD(LCSP));
CP := NIL;
FOR I := 1 TO 2 DO
ENTERSTDID(KONST,NA[STDCONST,I],BOOLPTR,CP,I-1);
WITH BOOLPTR↑ DO
BEGIN
FCONST := CP; VECTORADDR := 0; VECTORCHAIN := 0;
TLEV := 0; REQUEST := FALSE; NEXTSCALAR := NIL;
DIMENSION := 1
END;
DECLSCALPTR := BOOLPTR;
CP := NIL;
FOR I := 3 TO 35 DO
ENTERSTDID(KONST,NA[STDCONST,I],ASCIIPTR,CP,I-3);
ENTERSTDID(KONST,NA[STDCONST,36],ASCIIPTR,CP,177B);
(*INPUT,OUTPUT,TTY,TTYOUTPUT*)
FOR I := 1 TO NAMAX[STDFILE] DO
BEGIN
NEW(CP,VARS);
STDFILEPTR[I] := CP;
WITH CP↑ DO
BEGIN
NAME := NA[STDFILE,I]; IDTYPE := TEXTPTR; CHANNEL := I-1;
VKIND := ACTUAL; NEXT := NIL; VLEV := 0;
VADDR:= LC;
LC:=LC+IDTYPE↑.SIZE;
NEW(LFILEPTR) ;
WITH LFILEPTR↑ DO
BEGIN
NEXTFTP := FILEPTR ;
FILEIDENT := CP
END ;
FILEPTR := LFILEPTR
END;
ENTERID(CP)
END;
(* GET,GETLN,PUT,PUTLN,RESET,REWRITE,READ,READLN,
WRITE,WRITELN,PACK,UNPACK,NEW,GETLINR,
PAGE,PROTECTION,RUN,DATE,TIME,DISPOSE,
HALT,GETSEG,PUTSEG,MESSAGE,LINELIMIT*)
FOR I := 1 TO NAMAX[STDPROC] DO
BEGIN
NEW(CP,PROC,STANDARD);
WITH CP↑ DO
BEGIN
NAME := NA[STDPROC,I]; IDTYPE := NIL;
NEXT := NIL; KEY := I
END;
ENTERID(CP)
END;
(* CLOCK,ABS,SQR,ODD,ORD,CHR,PRED,SUCC,EOF,EOLN,REALTIME,CARD,EXPO,
LOWERBOUND,UPPERBOUND,MIN,MAX,FIRST,LAST,EOS*)
FOR I := 1 TO NAMAX[STDFUNC] DO
BEGIN
NEW(CP,FUNC,STANDARD);
WITH CP↑ DO
BEGIN
NAME := NA[STDFUNC,I]; IDTYPE := NIL;
NEXT := NIL; KEY := I
END;
ENTERID(CP)
END;
(* COS,EXP,SQRT,ALOG,ATAN,ALOG10,
SIND,COSD,SINH,COSH,TANH,ASIN,ACOS,RAN,SIN*)
ENTERSTDPARAMETER(REALPTR,ACTUAL,NIL,2);
FOR I := 1 TO 15 DO ENTERSTDPROCFUNC(I,FUNC,REALPTR,CP);
(* ROUND, EXPO *)
ENTERSTDPROCFUNC(16,FUNC,INTPTR,CP);
ENTERSTDPROCFUNC(17,FUNC,INTPTR,CP);
(* OPTION *)
ENTERSTDPARAMETER(ALFAPTR,ACTUAL,NIL,2);
ENTERSTDPROCFUNC(18,FUNC,BOOLPTR,CP);
(* TRUNC *)
ENTERSTDPARAMETER(REALPTR,ACTUAL,NIL,2);
ENTERSTDPROCFUNC(20,FUNC,INTPTR,CP);
(* GETFILENAME *)
ENTERSTDPARAMETER(ALFAPTR,ACTUAL,NIL,6);
ENTERSTDPARAMETER(PACKC6PTR,FORMAL,CP,5);
ENTERSTDPARAMETER(INTPTR,FORMAL,CP,4);
ENTERSTDPARAMETER(INTPTR,FORMAL,CP,3);
ENTERSTDPARAMETER(PACKC9PTR,FORMAL,CP,2);
ENTERSTDPARAMETER(ANYFILEPTR,FORMAL,CP,1);
ENTERSTDPROCFUNC(1,PROC,NIL,CP);
(* GETOPTION *)
ENTERSTDPARAMETER(INTPTR,FORMAL,NIL,4);
ENTERSTDPARAMETER(ALFAPTR,ACTUAL,CP,2);
ENTERSTDPROCFUNC(2,PROC,NIL,CP);
(* GETSTATUS *)
ENTERSTDPARAMETER(PACKC6PTR,FORMAL,NIL,5);
ENTERSTDPARAMETER(INTPTR,FORMAL,CP,4);
ENTERSTDPARAMETER(INTPTR,FORMAL,CP,3);
ENTERSTDPARAMETER(PACKC9PTR,FORMAL,CP,2);
ENTERSTDPARAMETER(ANYFILEPTR,FORMAL,CP,1);
ENTERSTDPROCFUNC(3,PROC,NIL,CP);
SEXTERNPFPTR := EXTERNPFPTR;
SFILEPTR := FILEPTR;
SDECLSCALPTR := DECLSCALPTR;
LCMAIN := LC
END (*ENTERSTDNAMES*) ;
PROCEDURE ENTERUNDECL;
VAR
I: INTEGER;
BEGIN
NEW(UTYPPTR,TYPES);
WITH UTYPPTR↑ DO
BEGIN
NAME := ' '; IDTYPE := NIL; NEXT := NIL
END;
NEW(UCSTPTR,KONST);
WITH UCSTPTR↑ DO
BEGIN
NAME := ' '; IDTYPE := NIL; NEXT := NIL;
VALUES.IVAL := 0
END;
NEW(UVARPTR,VARS);
WITH UVARPTR↑ DO
BEGIN
NAME := ' '; IDTYPE := NIL; VKIND := ACTUAL;
NEXT := NIL; VLEV := 0; VADDR := 0
END;
NEW(UFLDPTR,FIELD);
WITH UFLDPTR↑ DO
BEGIN
NAME := ' '; IDTYPE := NIL; NEXT := NIL; FLDADDR := 0;
PACKF := NOTPACK
END;
NEW(UPRCPTR,PROC,DECLARED,ACTUAL);
WITH UPRCPTR↑ DO
BEGIN
NAME := ' '; IDTYPE := NIL; FORWDECL := FALSE;
FOR I := 0 TO MAXLEVEL DO LINKCHAIN[I] := 0;
NEXT := NIL; EXTERNDECL := FALSE; PFLEV := 0; PFADDR := 0
END;
NEW(UFCTPTR,FUNC,DECLARED,ACTUAL);
WITH UFCTPTR↑ DO
BEGIN
NAME := ' '; IDTYPE := NIL; NEXT := NIL;
FOR I := 0 TO MAXLEVEL DO LINKCHAIN[I] := 0;
FORWDECL := FALSE; EXTERNDECL := FALSE; PFLEV := 0; PFADDR := 0
END
END (*ENTERUNDECL*) ;
BEGIN (*PASCAL*)
DATE(DAY); TIME(TIMEOFDAY);
INIT←COMPILE;
(*ENTER STANDARD NAMES AND STANDARD TYPES:*)
(******************************************)
LEVEL := 0; TOP := 0;
WITH DISPLAY[0] DO
BEGIN
FNAME := NIL; OCCUR := BLCK
END;
ENTERSTDTYPES; ENTERSTDNAMES; ENTERUNDECL;
TOP := 1; LEVEL := 1;
WITH DISPLAY[1] DO
BEGIN
FNAME := NIL; OCCUR := BLCK
END;
GET←DIRECTIVES;
IF NOT OPTION('NOCOMPILE ')
THEN
BEGIN
IF LPTFILE
THEN
BEGIN
WRITELN(LIST,'PASCAL COMPILATION LIST PRODUCED BY ',HEADER,' ON ',DAY,' AT ',TIMEOFDAY); WRITELN(LIST)
END;
LOOP
COMPILE
EXIT IF NOT EXTERNAL OR EOF(SOURCE);
INIT←COMPILE
END
END (* IF NOT OPTION('NOCOMPILE ') *);
0:
IF NOT ERROR←FLAG
THEN
BEGIN
IF CROSS←REFERENCE
THEN
BEGIN
IF LPTFILE
THEN RESET(LIST) ; (* CLOSE LIST←FILE *)
REWRITE(TEMPCORE,'CRO TMP');
WRITE(TEMPCORE,SOURCE←FILE:6, '.' ,
SOURCE←FILE[7],SOURCE←FILE[8],SOURCE←FILE[9], ',' ,
OBJECT←FILE:6,'.NEW,',OBJECT←FILE:6,'.CRL');
IF LOAD←AND←GO
THEN WRITE(TEMPCORE,'/LINK');
CALL('CROSS ',CROSS←DEVICE,CROSS←PPN,CROSS←CORE)
END;
IF LOAD←AND←GO
THEN
BEGIN
WRITELN(TTY); BREAK(TTY);
CALL('LINK ')
END
END
ELSE
BEGIN
REWRITE(OBJECT);
RESET(TEMPCORE,'LNK TMP')
END
END (*PASCAL*).